MUMPS_5.1.2/0000775000175000017500000000000013164366271012735 5ustar jylexceljylexcelMUMPS_5.1.2/Makefile0000664000175000017500000000373413164366235014404 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # topdir = . libdir = $(topdir)/lib default: dexamples .PHONY: default alllib all c z s d \ sexamples dexamples cexamples zexamples multi_example \ mumps_lib requiredobj libseqneeded clean alllib: c z s d all: cexamples zexamples sexamples dexamples multi_example c: $(MAKE) ARITH=c mumps_lib z: $(MAKE) ARITH=z mumps_lib s: $(MAKE) ARITH=s mumps_lib d: $(MAKE) ARITH=d mumps_lib # Is Makefile.inc available ? Makefile.inc: @echo "######################################################################" @echo "# BEFORE COMPILING MUMPS, YOU SHOULD HAVE AN APPROPRIATE FILE" @echo "# Makefile.inc AVALAIBLE. PLEASE LOOK IN THE DIRECTORY ./Make.inc FOR" @echo "# EXAMPLES OF Makefile.inc FILES, AT Make.inc/Makefile.inc.generic" @echo "# IN CASE YOU NEED TO BUILD A NEW ONE AND READ THE MAIN README FILE" @echo "######################################################################" @exit 1 include Makefile.inc mumps_lib: requiredobj (cd src ; $(MAKE) $(ARITH)) cexamples: c (cd examples ; $(MAKE) c) zexamples: z (cd examples ; $(MAKE) z) sexamples: s (cd examples ; $(MAKE) s) dexamples: d (cd examples ; $(MAKE) d) multi_example: s d c z (cd examples ; $(MAKE) multi) requiredobj: 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.1.2/README0000664000175000017500000000436513164366235013625 0ustar jylexceljylexcel=========================================== MUMPS 5.1.2 =========================================== MUMPS 5.1.2 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. Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, University of Bordeaux. This version of MUMPS is provided to you free of charge. It is released under the CeCILL-C license: http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html Contents of the distribution: ---------------------------- ChangeLog LICENSE CREDITS INSTALL README VERSION Makefile Make.inc/ doc/ src/ lib/ include/ ibseq/ 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.1.2/Make.inc/0000775000175000017500000000000013164366235014362 5ustar jylexceljylexcelMUMPS_5.1.2/Make.inc/Makefile.SP.PAR0000664000175000017500000000750213164366235016770 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.WIN.MS-Intel.SEQ0000664000175000017500000000731613164366235020503 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # # 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_ -fpp OPTL = OPTC = -O2 -MD #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.1.2/Make.inc/Makefile.SGI.SEQ0000664000175000017500000000655413164366235017104 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.SP.SEQ0000664000175000017500000000731313164366235016776 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.NEC.PAR0000664000175000017500000000663613164366235017062 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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 = sxcc FC = sxmpif90 FL = sxmpif90 AR = sxar vr RANLIB = echo # # Use module load scalapack, module load blas, etc. # #LAPACK = -llapack #SCALAP = -lscalapack -lblacs -lblacsCinit -lblacsF90init #INCPAR = -I/usr/lib #LIBPAR = $(SCALAP) $(LAPACK) -L/usr/lib -lmpi -lmpi++ INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq # LIBBLAS = -lcblas -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimization options OPTF = OPTL = OPTC = -Kc99 -O -I #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.1.2/Make.inc/Makefile.SP64.PAR0000664000175000017500000000742313164366235017144 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.WIN.MS-G95.SEQ0000664000175000017500000000721513164366235017772 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # # 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.1.2/Make.inc/Makefile.FREEBSD10.PAR0000664000175000017500000000700113164366235017653 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.INTEL.SEQ0000664000175000017500000000711013164366235017322 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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 # or -openmp for old compilers OPTL = -O -nofor_main -qopenmp OPTC = -O -qopenmp #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.1.2/Make.inc/Makefile.G95.SEQ0000664000175000017500000000661213164366235017021 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.SGI.PAR0000664000175000017500000000673313164366235017075 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.debian.PAR0000664000175000017500000000371413164366235017671 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # # 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 lapack-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 SCALAP = -lscalapack-openmpi -lblacs-openmpi -lblacsF77init-openmpi -lblacsCinit-openmpi INCPAR = -I/usr/lib/openmpi/include LIBPAR = $(SCALAP) $(LAPACK) -lmpi -lmpi_f77 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 # -fopenmp #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.1.2/Make.inc/Makefile.FREEBSD10.SEQ0000664000175000017500000000663413164366235017674 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.SP64.SEQ0000664000175000017500000000722613164366235017153 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.inc.generic0000664000175000017500000001304013164366235020203 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # ################################################################################ # # 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.1.2/Make.inc/Makefile.debian.SEQ0000664000175000017500000000345413164366235017700 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # # 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 lapack-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 # uncomment -fopenmp in lines below to benefit from OpenMP OPTF = -O # -fopenmp OPTL = -O # -fopenmp OPTC = -O # -fopenmp #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.1.2/Make.inc/Makefile.SUN.PAR0000664000175000017500000000656313164366235017121 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.G95.PAR0000664000175000017500000000725413164366235017016 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.inc.generic.SEQ0000664000175000017500000001233013164366235020633 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # ################################################################################ # # 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.1.2/Make.inc/Makefile.INTEL.PAR0000664000175000017500000000724613164366235017326 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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 # or -openmp for old compilers OPTL = -O -nofor_main -qopenmp OPTC = -O -qopenmp #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.1.2/Make.inc/Makefile.SUN.SEQ0000664000175000017500000000637313164366235017126 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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.1.2/Make.inc/Makefile.NEC.SEQ0000664000175000017500000000644313164366235017064 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # #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 = sxcc FC = sxmpif90 FL = sxmpif90 AR = sxar vr RANLIB = echo # # Use module load scalapack, module load blas, etc. # #LAPACK = -llapack INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq # LIBBLAS = -lcblas -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimization options OPTF = OPTL = OPTC = -Kc99 -O -I #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.1.2/CREDITS0000664000175000017500000000321713164366235013760 0ustar jylexceljylexcelThis version of MUMPS has been developed by employees of CERFACS, ENS Lyon, INPT(ENSEEIHT)-IRIT, Inria 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, Stephane Pralet, Chiara Puglisi, Francois-Henry Rouet, Wissam Sid-Lakhdar, Tzvetomila Slavova, Bora Ucar and Clement Weisbecker. We are grateful to Caroline Bousquet, Indranil Chowdhury, Christophe Daniel, Iain Duff, Vincent Espirat, 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, Altair, Airbus Group-IW, EDF, EMGS, ESI Group, FFT, LBNL, LSTC, Michelin, SAFRAN, SAMTECH, 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, CICT-CALMIP (Centre Interuniversitaire de Calcul de 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.1.2/include/0000775000175000017500000000000013164366262014360 5ustar jylexceljylexcelMUMPS_5.1.2/include/cmumps_c.h0000664000175000017500000000663613164366240016346 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2" #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[40]; MUMPS_INT keep[500]; CMUMPS_REAL cntl[15]; CMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; 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; /* 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; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT info[40],infog[40]; 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]; } CMUMPS_STRUC_C; void MUMPS_CALL cmumps_c( CMUMPS_STRUC_C * cmumps_par ); #ifdef __cplusplus } #endif #endif /* CMUMPS_C_H */ MUMPS_5.1.2/include/cmumps_struc.h0000664000175000017500000002575513164366262017273 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.1.2, released ! on Mon Oct 2 07:37:01 UTC 2017 ! ! ! Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license: ! http://www.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 ! ! ! ****************** ! 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 INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER :: LRHS, NRHS, NZ_RHS, LSOL_loc, LREDRHS INTEGER :: pad5 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(40) INTEGER :: INFO(40) INTEGER :: INFOG(40) REAL :: COST_SUBTREES REAL :: CNTL(15) REAL :: RINFO(40) REAL :: RINFOG(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 ! ------------------------------------------ ! To save the matrix in matrix market format ! ------------------------------------------ CHARACTER(LEN=255) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=255) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad8 ! ! ! ********************** ! 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 INTEGER :: LBUFR INTEGER :: LBUFR_BYTES INTEGER, DIMENSION(:), POINTER :: BUFR ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS ! IS1 (maxis1) contains working arrays computed ! and used only during analysis INTEGER, DIMENSION(:), POINTER :: IS1 ! For analysis/facto/solve phases INTEGER :: MAXIS1, Deficiency 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 ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! --------------------- INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! The two pointer arrays computed in facto and used by the solve ! (except the factors) are PTLUST_S and PTRFAC. 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(LEN=1), DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER(LEN=1), DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore INTEGER :: LPOOL_AFTER_L0_OMP, LPOOL_BEFORE_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING,pad15 INTEGER(8) :: THREAD_LA ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_BEFORE_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_AFTER_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! 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 subtrees INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! for RR on root REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES ! 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.1.2/include/zmumps_c.h0000664000175000017500000000663613164366240016375 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2" #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[40]; MUMPS_INT keep[500]; ZMUMPS_REAL cntl[15]; ZMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; 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; /* 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; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT info[40],infog[40]; 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]; } ZMUMPS_STRUC_C; void MUMPS_CALL zmumps_c( ZMUMPS_STRUC_C * zmumps_par ); #ifdef __cplusplus } #endif #endif /* ZMUMPS_C_H */ MUMPS_5.1.2/include/mumps_c_types.h0000664000175000017500000000265013164366240017417 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html * */ #ifndef MUMPS_C_TYPES_H #define MUMPS_C_TYPES_H #include #ifdef 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.1.2/include/dmumps_struc.h0000664000175000017500000002625513164366262017270 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.1.2, released ! on Mon Oct 2 07:37:01 UTC 2017 ! ! ! Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license: ! http://www.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 ! ! ! ****************** ! 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 INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER :: LRHS, NRHS, NZ_RHS, LSOL_loc, LREDRHS INTEGER :: pad5 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(40) INTEGER :: INFO(40) INTEGER :: INFOG(40) DOUBLE PRECISION :: COST_SUBTREES DOUBLE PRECISION :: CNTL(15) DOUBLE PRECISION :: RINFO(40) DOUBLE PRECISION :: RINFOG(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 ! ------------------------------------------ ! To save the matrix in matrix market format ! ------------------------------------------ CHARACTER(LEN=255) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=255) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad8 ! ! ! ********************** ! 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 INTEGER :: LBUFR INTEGER :: LBUFR_BYTES INTEGER, DIMENSION(:), POINTER :: BUFR ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS ! IS1 (maxis1) contains working arrays computed ! and used only during analysis INTEGER, DIMENSION(:), POINTER :: IS1 ! For analysis/facto/solve phases INTEGER :: MAXIS1, Deficiency 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 ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! --------------------- INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! The two pointer arrays computed in facto and used by the solve ! (except the factors) are PTLUST_S and PTRFAC. 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(LEN=1), DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER(LEN=1), DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore INTEGER :: LPOOL_AFTER_L0_OMP, LPOOL_BEFORE_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING,pad15 INTEGER(8) :: THREAD_LA ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_BEFORE_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_AFTER_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! 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 subtrees INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! for RR on root DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES ! 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.1.2/include/dmumps_root.h0000664000175000017500000000357113164366262017107 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.1.2, released ! on Mon Oct 2 07:37:01 UTC 2017 ! ! ! Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license: ! http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html ! 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 MUMPS_5.1.2/include/cmumps_root.h0000664000175000017500000000346413164366262017107 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.1.2, released ! on Mon Oct 2 07:37:01 UTC 2017 ! ! ! Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license: ! http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html ! 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 MUMPS_5.1.2/include/dmumps_c.h0000664000175000017500000000663613164366240016347 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2" #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[40]; MUMPS_INT keep[500]; DMUMPS_REAL cntl[15]; DMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; 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; /* 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; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT info[40],infog[40]; 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]; } DMUMPS_STRUC_C; void MUMPS_CALL dmumps_c( DMUMPS_STRUC_C * dmumps_par ); #ifdef __cplusplus } #endif #endif /* DMUMPS_C_H */ MUMPS_5.1.2/include/smumps_c.h0000664000175000017500000000663613164366240016366 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2" #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[40]; MUMPS_INT keep[500]; SMUMPS_REAL cntl[15]; SMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; 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; /* 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; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT info[40],infog[40]; 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]; } SMUMPS_STRUC_C; void MUMPS_CALL smumps_c( SMUMPS_STRUC_C * smumps_par ); #ifdef __cplusplus } #endif #endif /* SMUMPS_C_H */ MUMPS_5.1.2/include/zmumps_struc.h0000664000175000017500000002624113164366262017311 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.1.2, released ! on Mon Oct 2 07:37:01 UTC 2017 ! ! ! Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license: ! http://www.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 ! ! ! ****************** ! 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 INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER :: LRHS, NRHS, NZ_RHS, LSOL_loc, LREDRHS INTEGER :: pad5 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(40) INTEGER :: INFO(40) INTEGER :: INFOG(40) DOUBLE PRECISION :: COST_SUBTREES DOUBLE PRECISION :: CNTL(15) DOUBLE PRECISION :: RINFO(40) DOUBLE PRECISION :: RINFOG(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 ! ------------------------------------------ ! To save the matrix in matrix market format ! ------------------------------------------ CHARACTER(LEN=255) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=255) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad8 ! ! ! ********************** ! 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 INTEGER :: LBUFR INTEGER :: LBUFR_BYTES INTEGER, DIMENSION(:), POINTER :: BUFR ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS ! IS1 (maxis1) contains working arrays computed ! and used only during analysis INTEGER, DIMENSION(:), POINTER :: IS1 ! For analysis/facto/solve phases INTEGER :: MAXIS1, Deficiency 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 ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! --------------------- INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! The two pointer arrays computed in facto and used by the solve ! (except the factors) are PTLUST_S and PTRFAC. 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(LEN=1), DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER(LEN=1), DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore INTEGER :: LPOOL_AFTER_L0_OMP, LPOOL_BEFORE_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING,pad15 INTEGER(8) :: THREAD_LA ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_BEFORE_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_AFTER_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! 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 subtrees INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! for RR on root DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES ! 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.1.2/include/smumps_root.h0000664000175000017500000000344513164366262017126 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.1.2, released ! on Mon Oct 2 07:37:01 UTC 2017 ! ! ! Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license: ! http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html ! 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 MUMPS_5.1.2/include/mumps_compat.h0000664000175000017500000000202513164366240017230 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/include/smumps_struc.h0000664000175000017500000002571113164366262017303 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.1.2, released ! on Mon Oct 2 07:37:01 UTC 2017 ! ! ! Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license: ! http://www.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 ! ! ! ****************** ! 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 INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER :: LRHS, NRHS, NZ_RHS, LSOL_loc, LREDRHS INTEGER :: pad5 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(40) INTEGER :: INFO(40) INTEGER :: INFOG(40) REAL :: COST_SUBTREES REAL :: CNTL(15) REAL :: RINFO(40) REAL :: RINFOG(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 ! ------------------------------------------ ! To save the matrix in matrix market format ! ------------------------------------------ CHARACTER(LEN=255) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=255) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad8 ! ! ! ********************** ! 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 INTEGER :: LBUFR INTEGER :: LBUFR_BYTES INTEGER, DIMENSION(:), POINTER :: BUFR ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS ! IS1 (maxis1) contains working arrays computed ! and used only during analysis INTEGER, DIMENSION(:), POINTER :: IS1 ! For analysis/facto/solve phases INTEGER :: MAXIS1, Deficiency 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 ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! --------------------- INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! The two pointer arrays computed in facto and used by the solve ! (except the factors) are PTLUST_S and PTRFAC. 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(LEN=1), DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER(LEN=1), DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore INTEGER :: LPOOL_AFTER_L0_OMP, LPOOL_BEFORE_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING,pad15 INTEGER(8) :: THREAD_LA ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_BEFORE_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_AFTER_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! 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 subtrees INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! for RR on root REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES ! 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.1.2/include/zmumps_root.h0000664000175000017500000000356413164366262017137 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.1.2, released ! on Mon Oct 2 07:37:01 UTC 2017 ! ! ! Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license: ! http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html ! 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 MUMPS_5.1.2/lib/0000775000175000017500000000000013164366235013503 5ustar jylexceljylexcelMUMPS_5.1.2/SCILAB/0000775000175000017500000000000013164366240013666 5ustar jylexceljylexcelMUMPS_5.1.2/SCILAB/initmumps.sci0000664000175000017500000000071313164366240016414 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,40)-9998,zeros(1,15)-9998,-9999,-9999,-9999,-9999,zeros(1,40)-9998,zeros(1,40)-9998,-9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999,0); endfunction MUMPS_5.1.2/SCILAB/zmumps.sci0000664000175000017500000000515113164366240015723 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.1.2/SCILAB/intmumpsc.c0000664000175000017500000005044613164366240016062 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=40, 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,40); 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=40; 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.1.2/SCILAB/builder.sce0000664000175000017500000000524313164366240016014 0ustar jylexceljylexcel// $Id: builder_source.sce 7142 2011-03-22 23:45:59Z jylexcel $ //******************* VARIABLE PART TO COSTUMIZE ***************************// // -- MUMPS: MUMPS_DIR = home + "/MUMPS_5.1.2"; 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.1.2/SCILAB/README0000664000175000017500000001165413164366240014555 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.1.2/SCILAB/examples/0000775000175000017500000000000013164366240015504 5ustar jylexceljylexcelMUMPS_5.1.2/SCILAB/examples/ex.sci0000664000175000017500000000022213164366240016614 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.1.2/SCILAB/examples/ex_rhs.sci0000664000175000017500000000007313164366240017474 0ustar jylexceljylexcelrhs(2,1)=3; rhs(5,1)=1; rhs(1,2)=8; rhs(2,2)=2; rhs(4,2)=3;MUMPS_5.1.2/SCILAB/examples/sparseRHS_example.sce0000664000175000017500000000200213164366240021557 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.1.2/SCILAB/examples/cmplx_example.sce0000664000175000017500000000173313164366240021042 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.1.2/SCILAB/examples/schur_example.sce0000664000175000017500000000317513164366240021045 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.1.2/SCILAB/examples/double_example.sce0000664000175000017500000000166213164366240021172 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.1.2/SCILAB/Help/0000775000175000017500000000000013164366240014556 5ustar jylexceljylexcelMUMPS_5.1.2/SCILAB/Help/help_initmumps.xml0000664000175000017500000000230213164366240020332 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.1.2/SCILAB/Help/help_dmumps.html0000664000175000017500000001603513164366240017766 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.1.2/SCILAB/Help/help_initmumps.html0000664000175000017500000000175213164366240020506 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.1.2/SCILAB/Help/manrev.dtd0000664000175000017500000000514213164366240016545 0ustar jylexceljylexcel MUMPS_5.1.2/SCILAB/Help/help_dmumps.xml0000664000175000017500000002074513164366240017625 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.1.2/SCILAB/Help/whatis.htm0000664000175000017500000000076313164366240016575 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.1.2/SCILAB/Help/help_zmumps.html0000664000175000017500000001603513164366240020014 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.1.2/SCILAB/Help/help_zmumps.xml0000664000175000017500000002074513164366240017653 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.1.2/SCILAB/dmumps.sci0000664000175000017500000000515113164366240015675 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.1.2/SCILAB/loader.sce0000664000175000017500000000144413164366240015633 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.1.2/src/0000775000175000017500000000000013164366266013530 5ustar jylexceljylexcelMUMPS_5.1.2/src/cfac_distrib_ELT.F0000664000175000017500000004714613164366264016771 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 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)) ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF 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 ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC)=ZERO ENDDO ENDIF 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 ARROW_ROOT = ARROW_ROOT + 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)==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) 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 ) ARROW_ROOT = ARROW_ROOT + NB_REC 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 (KEEP(38).ne.0) THEN DEALLOCATE(ELROOTPOS8) 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.1.2/src/carrowheads.F0000664000175000017500000006742413164366264016154 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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( 40 ) 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 INTEGER(8) :: IPTRI, IPTRR 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), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), SLAVEF ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), SLAVEF ) 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 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), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), SLAVEF ) 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. 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 ) IMPLICIT NONE INCLUDE 'cmumps_root.h' 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,INEW,JNEW,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 TYPENODE_TMP, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: I1, IA, IIW, IS1, IS, IAS, ISHIFT, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, POINTER, DIMENSION(:,:) :: IW4 ARROW_ROOT = 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 ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER(int(I-1,8)*int(root%SCHUR_LLD,8)+1_8: & int(I-1,8)*int(root%SCHUR_LLD,8)+int(root%SCHUR_MLOC,8))= & ZERO ENDDO ENDIF 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 DO 120 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 GOTO 120 END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF 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 ENDIF ENDIF IARR = abs( ISEND ) ISTEP = abs( STEP(IARR) ) TYPENODE_TMP = MUMPS_TYPENODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE = MUMPS_PROCNODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & SLAVEF ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF (TYPENODE_TMP.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) 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 IF ( TYPENODE_TMP .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPENODE_TMP .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 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 )/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 END IF 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 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPENODE_TMP .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 IIW = IS1 + ISHIFT + 2_8 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = 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 ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 .OR. .TRUE.) & .AND. IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF (MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) == 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 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)) END IF 120 CONTINUE 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 & ) IMPLICIT NONE INCLUDE 'cmumps_root.h' 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 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 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) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I=1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC)=ZERO ENDDO ENDIF 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)))), & SLAVEF ) .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 .OR. .TRUE.) & .AND. IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) 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 MUMPS_5.1.2/src/slr_type.F0000664000175000017500000000420713164366263015500 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE SMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE REAL,POINTER,DIMENSION(:,:) :: Q,R INTEGER :: LRFORM,K,M,N,KSVD LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT,KEEP8,IS_FACTOR) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER(8) :: KEEP8(150) INTEGER :: MEM 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 KEEP8(70) = KEEP8(70) + int(MEM,8) IF (.NOT.IS_FACTOR) THEN KEEP8(71) = KEEP8(71) + int(MEM,8) ENDIF 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, NB_BLR, KEEP8, IS_FACTOR) INTEGER, INTENT(IN) :: NB_BLR TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: I IF (NB_BLR.GT.0) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=1, NB_BLR CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8, IS_FACTOR) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE SMUMPS_LR_TYPE MUMPS_5.1.2/src/ana_omp_m.F0000664000175000017500000000116413164366241015560 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE MUMPS_ANA_OMP_RETURN() C C Research work on multithreaded tree parallelism initiated in C the context of the PhD thesis of Wissam Sid-Lakhdar (ENS Lyon) C might impact a future release. C RETURN END SUBROUTINE MUMPS_ANA_OMP_RETURN MUMPS_5.1.2/src/cfac_process_root2son.F0000664000175000017500000003225413164366264020142 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 40 ) 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 NBPROCFILS(KEEP(28)) 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 ) 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)),SLAVEF) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & SLAVEF ).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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), SLAVEF) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 7 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO #endif ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 9 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO_SYM #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, 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.1.2/src/sfac_front_LDLT_type2.F0000664000175000017500000006533113164366263017732 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NOFFW, & NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'smumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 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(40), 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), & 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)), NBPROCFILS(KEEP(28)), & 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 INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTBL, LR_ACTIVATED 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 HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER PIVOT_OPTION EXTERNAL SMUMPS_BDC_ERROR LOGICAL STATICMODE REAL SEUIL_LOC REAL GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV REAL ONE PARAMETER (ONE = 1.0E0) NULLIFY(BLR_L) IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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 PIVOT_OPTION = MIN(2,KEEP(468)) IF (UUTEMP == 0.0E0 .AND. KEEP(201).NE.1) THEN 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 IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. NULLIFY(BEGS_BLR) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) 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 K263 = 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 IF (KEEP(201).EQ.1) THEN IDUMMY = -9876 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 CNT_NODES = CNT_NODES + 1 CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL SYSTEM_CLOCK(TTOT1FR) ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.2) PIVOT_OPTION=2 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 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 IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) 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,NOFFW,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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IF (IFLAG.LT.0) GOTO 490 IF(KEEP(109).GT. 0) THEN IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN IWPOSPIV = IOLDPS+IW(IOLDPS+1+XSIZE)+6 & +IW(IOLDPS+5+XSIZE) PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+XSIZE) ENDIF ENDIF IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN NPVW = NPVW + PIVSIZ IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. & ( (KEEP(485).EQ.0) .AND. (PIVOT_OPTION.GT.2) ) & ) & ) 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,IEND_BLR,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & PIVOT_OPTION, .FALSE.) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 2, 1) ENDIF IF (LR_ACTIVATED) THEN 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 GOTO 101 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V', 2) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 ENDIF 101 CONTINUE 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8,PIVOT_OPTION, .TRUE.) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) CALL MUMPS_ABORT() #if defined(BLR_MT) !$OMP PARALLEL #endif IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 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(8), KEEP(477) & ) IF (IFLAG.LT.0) GOTO 450 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 100 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (PIVOT_OPTION.LE.2) THEN CALL SYSTEM_CLOCK(T1) CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & NASS, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) ELSE IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & NASS, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) END IF ENDIF CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 (KEEP(201).EQ.1) 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 500 480 CONTINUE write(*,*) 'Allocation problem in BLR routine & SMUMPS_FAC_FRONT_LDLT_TYPE2: ', & 'not enough memory? memory requested = ' , IERROR 490 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, 1, INODE, & NELIM) CALL STATS_COMPUTE_FLOP_FRONT_TYPE2(NFRONT, NASS, KEEP(50), & INODE, NELIM) CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), & 2) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) 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.1.2/src/dfac_type3_symmetrize.F0000664000175000017500000001363313164366263020153 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/mumps_pord.h0000664000175000017500000000337213164366240016063 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/src/csol_aux.F0000664000175000017500000010352213164366264015455 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) COMPLEX W(N), X(N) REAL, intent(inout) :: EST 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) 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) 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 ) 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 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) 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) 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) 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)) 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)) 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) # if defined(RHSCOMP_BYROWS) COMPLEX, INTENT(INOUT) :: RHSCOMP(NRHS,LRHSCOMP) # else COMPLEX, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) # endif INTEGER :: LD_W, FIRST_ROW_W COMPLEX :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT #if defined(RHSCOMP_BYROWS) !$OMP PARALLEL DO PRIVATE (ISHIFT, K), IF !$OMP& ((NBROWS) * (JBFIN-JBDEB+1) > KEEP(363)) DO JJ = 0, NBROWS-1 ISHIFT = FIRST_ROW_W+JJ DO K = JBDEB, JBFIN RHSCOMP(K,FIRST_ROW_RHSCOMP+JJ) = & W(ISHIFT+LD_W*(K-JBDEB)) END DO END DO !$OMP END PARALLEL DO #else !$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 #endif 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) # if defined(RHSCOMP_BYROWS) COMPLEX, INTENT(INOUT) :: RHSCOMP(NRHS,LRHSCOMP) # else COMPLEX, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) # endif COMPLEX :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSCOMP_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSCOMP #if defined(RHSCOMP_BYROWS) !$OMP PARALLEL DO PRIVATE(K,ISHIFT,IPOSINRHSCOMP), IF !$OMP& ((JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>KEEP(363)) DO JJ = J1, J2-KEEP(253) ISHIFT = FIRST_ROW_W+JJ-J1 IPOSINRHSCOMP = abs(POSINRHSCOMP_BWD(IW(JJ))) DO K=JBDEB, JBFIN W(ISHIFT+(K-JBDEB)*LD_W) = RHSCOMP(K,IPOSINRHSCOMP) ENDDO ENDDO !$OMP END PARALLEL DO #else !$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 #endif 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(40), 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 MUMPS_5.1.2/src/slr_core.F0000664000175000017500000007601713164366266015462 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE SMUMPS_LR_CORE USE MUMPS_LR_COMMON USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,KSVD,M,N,ISLR) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,KSVD,M,N LOGICAL,INTENT(IN) :: ISLR C This routine simply initializes a LR block but does NOT allocate it LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%KSVD = KSVD LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) IF (ISLR) THEN LRB_OUT%LRFORM = 1 ELSE LRB_OUT%LRFORM = 0 ENDIF END SUBROUTINE INIT_LRB SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS, K486, K489, & K490, K491, K492, N, LRGROUPS, LRSTATUS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, K486, K489, K490, & K491, K492 INTEGER,INTENT(IN) :: N, LRGROUPS(N) INTEGER,INTENT(OUT):: LRSTATUS C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB COMPRESS_PANEL = .FALSE. IF ((K486.GT.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.EQ.1) COMPRESS_PANEL =.FALSE. IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF COMPRESS_CB = .FALSE. IF ((K492.GT.0).AND.(K489.EQ.1).AND.(NFRONT-NASS.GT.K491)) THEN COMPRESS_CB = .TRUE. ENDIF 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 END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,KSVD,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,KSVD,M,N INTEGER,INTENT(OUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok REAL :: ZERO PARAMETER (ZERO = 0.0D0) 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) write(*,*) 'Allocation problem in BLR routine ALLOC_LRB:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF ENDIF ELSE allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N write(*,*) 'Allocation problem in BLR routine ALLOC_LRB:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF nullify(LRB_OUT%R) ENDIF LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%KSVD = KSVD LRB_OUT%ISLR = ISLR IF (ISLR) THEN LRB_OUT%LRFORM = 1 ELSE LRB_OUT%LRFORM = 0 ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF KEEP8(70) = KEEP8(70) - int(MEM,8) KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - int(MEM,8) KEEP8(69) = min(KEEP8(71), KEEP8(69)) END SUBROUTINE ALLOC_LRB 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 LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2 ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1)) 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)) DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE SMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, POSELTD, & 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_LRGEMM3) 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) :: POSELTD, POSELTT INTEGER, INTENT(IN) :: MAXI_CLUSTER REAL, intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS REAL :: PIV1, PIV2, OFFDIAG IF (LRB%LRFORM.EQ.1) THEN NROWS = LRB%K ELSE ! Full Rank Block NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot 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: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_LRGEMM3(TRANSB1, TRANSB2, ALPHA, & LRB1, LRB2, BETA, A, LA, POSELTT, NFRONT, SYM, NIV, & IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, RANK, BUILDQ, & POSELTD, LD_DIAG, IW2, BLOCK, MAXI_CLUSTER) TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, NIV INTEGER,INTENT(OUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8), INTENT(IN), OPTIONAL :: POSELTD INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER CHARACTER(len=1),INTENT(IN) :: TRANSB1, TRANSB2 INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT REAL, intent(in) :: TOLEPS REAL :: ALPHA,BETA REAL, intent(inout), OPTIONAL :: BLOCK(:) REAL, ALLOCATABLE, DIMENSION(:,:) :: XY_YZ REAL, ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y REAL, POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSX, TRANSY, TRANSZ INTEGER :: M_X, K_XY, K_YZ, N_Z, LDX, LDY, LDY1, LDY2, LDZ, K_Y INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK LOGICAL :: BUILDQ REAL, ALLOCATABLE :: RWORK_RRQR(:) REAL, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: T1, T2, CR INTEGER :: allocok, MREQ DOUBLE PRECISION :: LOC_UPDT_TIME_OUT REAL, EXTERNAL ::snrm2 REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (LRB2%M.EQ.0) THEN write(*,*) "Internal error in SMUMPS_LRGEMM3, LRB2%M=0" CALL MUMPS_ABORT() ENDIF IF ((SYM.NE.0).AND.((TRANSB1.NE.'N').OR.(TRANSB2.NE.'T'))) THEN WRITE(*,*) "SYM > 0 and (", TRANSB1, ",", TRANSB2, & ") parameters found. Symmetric LRGEMM is only ", & "compatible with (N,T) parameters" CALL MUMPS_ABORT() ENDIF RANK = 0 BUILDQ = .FALSE. IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==1)) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) GOTO 700 allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 860 ENDIF IF (TRANSB1 == 'N') THEN X => LRB1%Q LDX = LRB1%M M_X = LRB1%M 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K ELSE !TRANSB1 == 'T' M_X = LRB1%N X => LRB1%R LDX = LRB1%K K_Y = LRB1%M Y1 => LRB1%Q LDY1 = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN Z => LRB2%R LDZ = LRB2%K N_Z = LRB2%N Y2 => LRB2%Q LDY2 = LRB2%M ELSE !TRANSB2 == 'T' N_Z = LRB2%M Z => LRB2%Q LDZ = LRB2%M Y2 => LRB2%R LDY2 = LRB2%K ENDIF TRANSZ = TRANSB2 CALL sgemm(TRANSB1 , TRANSB2 , LRB1%K , LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) BUILDQ = .FALSE. IF (COMPRESS_MID_PRODUCT.GE.1) THEN LWORK = MAX(LRB2%K**2, M_X**2) 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 860 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(1), TAU_RRQR(1), WORK_RRQR(1), & LRB2%K, RWORK_RRQR(1), TOLEPS, RANK, MAXRANK, INFO) IF ((RANK.GT.MAXRANK).OR.(RANK.EQ.0)) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN ! Successfully compressed middle block allocate(XQ(M_X,RANK), R_Y(RANK,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = M_X*RANK + RANK*LRB2%K GOTO 860 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 CALL sorgqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL sgemm(TRANSB1, 'N', M_X, RANK, LRB1%K, ONE, & X(1,1), LDX, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), M_X) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ LDX = M_X K_XY = RANK TRANSX = 'N' deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSX = TRANSB1 TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE ! LRB1%K < LRB2%K SIDE = 'R' ENDIF ENDIF ENDIF IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN IF (LRB1%K.EQ.0) GOTO 700 SIDE = 'R' K_XY = LRB1%K TRANSX = TRANSB1 TRANSY = TRANSB1 Z => LRB2%Q LDZ = LRB2%M TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN X => LRB1%Q LDX = LRB1%M M_X = LRB1%M 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF ELSE ! TRANSB1 == 'T' X => LRB1%R LDX = LRB1%K M_X = LRB1%N Y => LRB1%Q LDY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN K_YZ = LRB2%M N_Z = LRB2%N ELSE ! TRANSB2 == 'T' K_YZ = LRB2%N N_Z = LRB2%M ENDIF ENDIF IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN IF (LRB2%K.EQ.0) GOTO 700 SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q LDX = LRB1%M TRANSX = TRANSB1 TRANSY = TRANSB2 TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN M_X = LRB1%M K_XY = LRB1%N ELSE ! TRANSB1 == 'T' M_X = LRB1%N K_XY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN Y => LRB2%Q LDY = LRB2%M Z => LRB2%R LDZ = LRB2%K N_Z = LRB2%N ELSE ! TRANSB2 == 'T' IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE ! Symmetric case: column scaling of R2 is done allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q LDZ = LRB2%M N_Z = LRB2%M ENDIF ENDIF IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' LDX = LRB1%M TRANSX = TRANSB1 Z => LRB2%Q LDZ = LRB2%M TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN M_X = LRB1%M K_XY = LRB1%N ELSE ! TRANSB1 == 'T' M_X = LRB1%N K_XY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN N_Z = LRB2%N ELSE ! TRANSB2 == 'T' N_Z = LRB2%M ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z allocate(XY_YZ(M_X,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = M_X*K_YZ GOTO 860 ENDIF CALL sgemm(TRANSX , TRANSY , M_X , K_YZ, K_XY, ONE, & X(1,1), LDX, Y(1,1), LDY, ZERO, XY_YZ(1,1), M_X) CALL SYSTEM_CLOCK(T1) CALL sgemm('N', TRANSZ, M_X, N_Z, K_YZ, ALPHA, & XY_YZ(1,1), M_X, Z(1,1), LDZ, BETA, A(POSELTT), & NFRONT) CALL SYSTEM_CLOCK(T2,CR) LOC_UPDT_TIME_OUT = dble(T2-T1)/dble(CR) CALL UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) deallocate(XY_YZ) ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ allocate(XY_YZ(K_XY,N_Z),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*N_Z GOTO 860 ENDIF CALL sgemm(TRANSY , TRANSZ , K_XY , N_Z, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LDZ, ZERO, XY_YZ(1,1), K_XY) CALL SYSTEM_CLOCK(T1) CALL sgemm(TRANSX, 'N', M_X, N_Z, K_XY, ALPHA, & X(1,1), LDX, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) CALL SYSTEM_CLOCK(T2,CR) LOC_UPDT_TIME_OUT = dble(T2-T1)/dble(CR) CALL UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) deallocate(XY_YZ) ELSE ! SIDE == 'N' : NONE; A = X*Z CALL sgemm(TRANSX, TRANSZ, M_X, N_Z, K_XY, ALPHA, & X(1,1), LDX, Z(1,1), LDZ, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 870 860 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine SMUMPS_LRGEMM3: ', & 'not enough memory? memory requested = ' , MREQ IFLAG = - 13 IERROR = MREQ RETURN 870 CONTINUE C Alloc ok!! IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE ! 1 AND 1 IF ((TRANSB1=='N').AND.(SYM .NE. 0)) deallocate(Y1) IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 700 CONTINUE END SUBROUTINE SMUMPS_LRGEMM3 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 END MODULE SMUMPS_LR_CORE SUBROUTINE SMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, 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 The authors of the LAPACK library are: C - Univ. of Tennessee C - Univ. of California Berkeley C - Univ. of Colorado Denver C - NAG Ltd. IMPLICIT NONE INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK REAL :: TOLEPS INTEGER :: JPVT(*) REAL :: RWORK(*) REAL :: A(LDA,*), TAU(*) REAL :: WORK(LDW,*) 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 CALL XERBLA( 'CGEQP3', -INFO ) RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RETURN END IF NB = ILAENV( INB, 'CGEQRF', ' ', M, N, -1, -1 ) 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 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 ) C IF(VN1(PVT).LT.TOLEPS) THEN IF(RWORK(PVT).LT.TOLEPS) 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 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 END DO RANK = RK END SUBROUTINE SMUMPS_TRUNCATED_RRQR MUMPS_5.1.2/src/dfac_b.F0000664000175000017500000002036313164366263015036 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_FAC_B(N, NSTEPS, & A, LA, IW, 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,INTARR,DBLARR, & root, NELT, FRTPTR, FRTELT, COMM_LOAD, & ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, & DKEEP,PIVNUL_LIST,LPN_LIST & ,LRGROUPS & ) USE DMUMPS_LOAD USE DMUMPS_FAC_PAR_M IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER(8) :: LA INTEGER N,NSTEPS,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA DOUBLE PRECISION A(LA) DOUBLE PRECISION RINFO(40) INTEGER LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER BUFR( LBUFR ) INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) INTEGER LRGROUPS(N) DOUBLE PRECISION CNTL1 INTEGER ICNTL(40) INTEGER INFO(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(LIW), 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(3*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 MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE DOUBLE PRECISION UULOC INTEGER LP, MPRINT INTEGER NSTK,PTRAST, NBPROCFILS INTEGER PIMASTER, PAMASTER LOGICAL PROK DOUBLE PRECISION ZERO, ONE DATA ZERO /0.0D0/ DATA ONE /1.0D0/ INTRINSIC int,real,log INTEGER IERR INTEGER NTOTPV, NTOTPVTOT, NMAXNPIV INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT KEEP(41)=0 KEEP(42)=0 NSTEPS = 0 LP = ICNTL(1) MPRINT = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) UULOC = CNTL1 IF (UULOC.GT.ONE) UULOC=ONE IF (UULOC.LT.ZERO) UULOC=ZERO IF (KEEP(50).NE.0.AND.UULOC.GT.0.5D0) THEN UULOC = 0.5D0 ENDIF PIMASTER = 1 NSTK = PIMASTER + KEEP(28) NBPROCFILS = NSTK + 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(67) = LRLUS KEEP8(68) = LRLUS KEEP8(69) = LRLUS KEEP8(70) = LRLUS KEEP8(71) = LRLUS IPTRLU = LRLU NTOTPV = 0 NMAXNPIV = 0 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))), SLAVEF ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF CALL DMUMPS_FAC_PAR(N,IW,LIW,A,LA,IW1(NSTK),IW1(NBPROCFILS), & NFSIZ,FILS,STEP,FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & INFO(11), NTOTPV, NMAXNPIV, 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,NSTEPS,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) & ) 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 ENDIF KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(31), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) KEEP8(68) = LA - KEEP8(68) KEEP8(69) = LA - KEEP8(69) KEEP(89) = NTOTPV KEEP(246) = NMAXNPIV INFO(23) = KEEP(89) 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 in mc51d 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 in mc51d NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(31), 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), INFO(25), RINFO(2), RINFO(3) 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/ & ' --- (25) NUMBER OF ENTRIES IN FACTORS =',I15/ & ' RINFO(2) OPERATIONS DURING NODE ASSEMBLY =',1PD10.3/ & ' -----(3) OPERATIONS DURING NODE ELIMINATION =',1PD10.3) END SUBROUTINE DMUMPS_FAC_B MUMPS_5.1.2/src/cmumps_iXamax.F0000664000175000017500000000212713164366264016452 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C INTEGER FUNCTION CMUMPS_IXAMAX(N,X,INCX) COMPLEX X(*) REAL ABSMAX INTEGER :: I INTEGER(8) :: IX INTEGER INCX,N CMUMPS_IXAMAX = 0 IF ( N.LT.1 ) RETURN CMUMPS_IXAMAX = 1 IF ( N.EQ.1 .OR. INCX.LE.0 ) RETURN 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 RETURN END FUNCTION CMUMPS_IXAMAX MUMPS_5.1.2/src/dfac_process_end_facto_slave.F0000664000175000017500000002373313164366263021473 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ) 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 #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) CALL DMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF), IFLAG, KEEP8, .TRUE.) IW(IOLDPS+XXS)=S_ALL 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, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG 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(70) = KEEP8(70) + MEM_GAIN KEEP8(71) = KEEP8(71) + MEM_GAIN CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) 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 IW(IOLDPS+XXS)=S_NOLCBCONTIG 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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, 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(70) = KEEP8(70) + MEM_GAIN KEEP8(71) = KEEP8(71) + 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/dfac_process_blfac_slave.F0000664000175000017500000004074613164366263020623 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS(KEEP(28)), 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 ) 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 IOLDPS, LCONT1, NROW1, NCOL1, NPIV1, NASS1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok LOGICAL SEND_LR INTEGER SEND_LR_INT 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 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, NB_BLR_COL, NPARTSASS_MASTER INTEGER :: MAXI_CLUSTER_TMP, MAXI_CLUSTER DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:):: BLOCKLR INTEGER :: LWORK DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK 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, & SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF IF (SEND_LR) 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))) ALLOCATE(BEGS_BLR_U(NB_BLR_U+2)) CALL DMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, KEEP(470), & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) IF ( LRLU .LT. LAELL ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLUS, IERROR) GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress DMUMPS_PROCESS_BLFAC_SLAVE' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLU, IERROR) GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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 (SEND_LR) THEN DYNAMIC = .FALSE. ENDIF IF (DYNAMIC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN write(*,*) MYID, ' : PB allocation U in blfac_slave ' & , LAELL 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(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) ) #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(INODE)) + 9 + KEEP(IXSZ) ) #else MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 )) POSELT = PTRAST(STEP( INODE )) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NASS1 = IW( IOLDPS + 1 + 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 (SEND_LR) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_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 ( & A, LA, POSELT, IFLAG, IERROR, NCOL1, & BEGS_BLR_LS, BEGS_BLR_U, & CURRENT_BLR_U, & BLR_LS, NB_BLR_LS+1, & BLR_U, NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, KEEP(470), & KEEP(481), DKEEP(8), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR_U, KEEP8, .FALSE.) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) CALL DMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8, .TRUE.) 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( LPOS ), NCOL1, ONE, & A( CPOS ), NCOL1 ) ELSE CALL dgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A( LPOS ), NCOL1, ONE, & A( 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.SEND_LR) THEN IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + 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)), SLAVEF ) 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 IF (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN IOLDPS = PTRIST(STEP( INODE )) CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) NB_BLR_LS = size(BEGS_BLR_LS) - 2 CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 CALL MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_TMP) MAXI_CLUSTER = MAXI_CLUSTER_TMP CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_TMP) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_TMP) LWORK = MAXI_CLUSTER*MAXI_CLUSTER ALLOCATE(RWORK(2*MAXI_CLUSTER),WORK(LWORK),TAU(MAXI_CLUSTER), & JPVT(MAXI_CLUSTER), BLOCKLR(MAXI_CLUSTER,MAXI_CLUSTER), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4) write(6,*) 'ERROR 1 allocate temporary BLR blocks during', & ' DMUMPS_PROCESS_BLFAC_SLAVE ', IERROR GOTO 700 ENDIF CALL DMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, & BEGS_BLR_COL, NB_BLR_COL, NPARTSASS_MASTER, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., 0, KEEP(484)) DEALLOCATE(RWORK,WORK,TAU,JPVT,BLOCKLR) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.1.2/src/cfac_mem_free_block_cb.F0000664000175000017500000000553513164366264020216 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_FREE_BLOCK_CB(SSARBR, MYID, N, IPOSBLOCK, & RPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) USE CMUMPS_LOAD IMPLICIT NONE INTEGER(8) :: RPOSBLOCK 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 INCLUDE 'mumps_headers.h' IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ) SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) ) 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 ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF ENDIF 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 IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF ENDIF 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 MUMPS_5.1.2/src/mumps_scotch.h0000664000175000017500000000311113164366240016371 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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) /* esmumps prototype with standard integers */ 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 ); #endif /*scotch or ptscotch*/ #if defined(ptscotch) #include "mpi.h" #include #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.1.2/src/sooc_panel_piv.F0000664000175000017500000002756213164366266016653 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zfac_distrib_distentry.F0000664000175000017500000006437413164366265020424 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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))), & SLAVEF ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & SLAVEF ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & SLAVEF ) 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 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( 40 ), ICNTL(40) 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, INEW, JNEW INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 LOGICAL T4_MASTER_CONCERNED COMPLEX(kind=8) VAL INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE 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 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 IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC) = ZERO ENDDO ENDIF 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) DO K8 = 1_8, NZ_loc8 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, & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF 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) ) CYCLE 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 (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 ENDIF ENDIF IARR = abs( ISEND ) ISTEP = abs(STEP(IARR)) TYPE_NODE = MUMPS_TYPENODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE= MUMPS_PROCNODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & SLAVEF ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF (TYPE_NODE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF ELSE 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 END IF if (DEST .eq. -1) 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 end if IF ( DEST.EQ.-1) THEN DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDDO 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, ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDIF ELSE 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, ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDIF ENDIF END DO DEST = -2 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, ARROW_ROOT, 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, & ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, & KEEP,KEEP8 ) IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER ARROW_ROOT, 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. -2 ) 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. -2 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -2 .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, & ARROW_ROOT, 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. -2 ) 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, & ARROW_ROOT, 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, ARROW_ROOT, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER NBRECORDS, N, ARROW_ROOT, 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, IROW_GRID, JCOL_GRID, & ILOCROOT, JLOCROOT INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT, IARR, JARR INTEGER TAILLE COMPLEX(kind=8) VAL 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 )))), & SLAVEF ) IF ( NODE_TYPE .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .NE. root%MYROW .OR. & JCOL_GRID .NE. root%MYCOL ) THEN WRITE(*,*) MYID,':INTERNAL Error: recvd root arrowhead ' WRITE(*,*) MYID,':not belonging to me. IARR,JARR=',IARR,JARR WRITE(*,*) MYID,':IROW_GRID,JCOL_GRID=',IROW_GRID,JCOL_GRID WRITE(*,*) MYID,':MYROW, MYCOL=', root%MYROW, root%MYCOL WRITE(*,*) MYID,':IPOSROOT,JPOSROOT=', IPOSROOT, JPOSROOT CALL MUMPS_ABORT() 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 IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) & .AND. & IW4(IARR,1) .EQ. 0 .AND. & IPROC .EQ. MYID & .AND. STEP(IARR) > 0 ) 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 ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.1.2/src/sfac_process_master2.F0000664000175000017500000001471313164366262017750 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, FRERE, & ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE SMUMPS_LOAD 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 ), 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' 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, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, 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 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 IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & SLAVEF) .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(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, & SLAVEF, 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.1.2/src/sana_LDLT_preprocess.F0000664000175000017500000007056213164366263017654 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER N,NCST INTEGER PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N,3) INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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,1) IF(K1 .GT. 0) THEN V1 = (abs(id%A(K1))*(id%ROWSCA(P1)**2).GE.1.0E-1) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2,1) IF(K2 .GT. 0) THEN V2 = (abs(id%A(K2))*(id%ROWSCA(P2)**2).GE.1.0E-1) 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) 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(40) 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) 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.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) 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 & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(40) 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) 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 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE 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 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.1.2/src/zsol_fwd_aux.F0000664000175000017500000014015513164366265016350 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, III, 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_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, III, LEAF, NBFIN, LRHSCOMP INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 40 ), 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 ) #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8) RHSCOMP( NRHS, LRHSCOMP ) #else COMPLEX(kind=8) RHSCOMP( LRHSCOMP, NRHS ) #endif 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 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 DOUBLE PRECISION :: TIME_TMP 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 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'Internal error 41r2 : Pool is too small.' CALL MUMPS_ABORT() END IF END IF 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))) #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) = & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + & WCB(PLEFTWCB+I-1) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) = & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) #endif ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF IF ( PTRICB(STEP(FINODE)) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'Internal error 41r2 : Pool is too small.' CALL MUMPS_ABORT() END IF ENDIF END IF 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 + (NPIV + NCV) * NRHS_B 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 IF (KEEP(201).GT.0) 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 APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201).EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE #endif CALL zgemm( 'N', 'N', NCV, NRHS_B, NPIV, ALPHA, & A(APOS), NCV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE #endif CALL zgemm( 'T', 'N', NCV, NRHS_B, NPIV, ALPHA, & A(APOS), NPIV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF IF (KEEP(201).GT.0) 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 - NPIV * NRHS_B PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & SLAVEF ) 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 IF (KEEP(350).EQ.0) THEN DO I = 1, NCV JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) DO K=1, NRHS_B #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + & WCB(PTRY+I-1+(K-1)*NCV) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PTRY+I-1+(K-1)*NCV) #endif ENDDO END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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)) #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) #endif & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF PTRICB(STEP(FINODE)) = & PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'INTERNAL Error 41r: Pool is too small.' 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, III, 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 - NCV * NRHS_B 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( INODE, & BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, III, 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, & MYROOT, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) USE ZMUMPS_OOC USE ZMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER INODE, LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, III, LEAF, NBFIN INTEGER MYROOT INTEGER INFO( 40 ), 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 ) COMPLEX(kind=8) RHS_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 #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8) RHSCOMP(NRHS, LRHSCOMP) #else COMPLEX(kind=8) RHSCOMP(LRHSCOMP, NRHS) #endif COMPLEX(kind=8) VALPIV, A11, A22, A12, DETPIV LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP 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)) DOUBLE PRECISION TIME_TMP INTEGER JBDEB, JBFIN, NRHS_B INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, & IERR, & LIELL, JJ, & NELIM INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: POSWCB1, POSWCB2 INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, & JFIN, NBJ, NUPDATE_PANEL, & NBK, NBK_ini, TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB INTEGER LDAJ, LDAJ_ini, LDAJ_FIRST_PANEL INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY( 1 ) DUMMY(1)=1 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 (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) 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+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 ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSCOMP_TMP = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.0) THEN DO JJ = J1, J3 IFR8 = IFR8 + 1_8 DO K=JBDEB,JBFIN RHS_ROOT(IFR8+int(NPIV,8)*int(K-1,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif END DO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP+JJ-J1) #else & RHSCOMP(IPOSINRHSCOMP_TMP+JJ-J1,K) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error in SOLVE_NODE for Root node' CALL MUMPS_ABORT() END IF MYROOT = MYROOT - 1 IF ( MYROOT .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 GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF (KEEP(201).EQ.1) 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 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 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)) GO TO 260 END IF IF (KEEP(201).EQ.1) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV DO K=JBDEB, JBFIN IFR8 = PPIV_COURANT+int(K-JBDEB,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 #if defined(RHSCOMP_BYROWS) WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) #endif IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDDO IF (NCB.GT.0) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) #if defined(RHSCOMP_BYROWS) WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) RHSCOMP (K,IPOSINRHSCOMP) = ZERO #else WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP (IPOSINRHSCOMP,K) = ZERO #endif ENDDO ENDIF ENDDO ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.0) THEN !$ OMP_FLAG = NRHS_B.GT.4 .AND. .FALSE. !$OMP PARALLEL DO PRIVATE(J,IFR8,K) IF(OMP_FLAG) DO 130 JJ = J1, J3 J = IW(JJ) IFR8 = IFR_ini8 + int(JJ-J1+1,8) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) WCB(IFR8+(K-JBDEB)*NPIV) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else WCB(IFR8+(K-JBDEB)*NPIV) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif END DO 130 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(JJ,IFR8) IF(OMP_FLAG) DO K=JBDEB, JBFIN IFR8 = IFR_ini8 + (K-JBDEB)*NPIV DO JJ = J1, J3 #if defined(RHSCOMP_BYROWS) WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF IFR8 = PCB_COURANT - 1_8 IF (NPIV .LT. LIELL) THEN IFR_ini8 = IFR8 IF (KEEP(350).EQ.0) THEN !$OMP PARALLEL DO PRIVATE(J,IFR8,K,IPOSINRHSCOMP) IF(OMP_FLAG) DO 140 JJ = J3 + 1, J2 J = IW(JJ) IFR8 = IFR_ini8 + (JJ-J3) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(IPOSINRHSCOMP,K) #endif #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP)=ZERO #else RHSCOMP(IPOSINRHSCOMP,K)=ZERO #endif ENDDO 140 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J2-J3)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP) IF (OMP_FLAG) DO K=JBDEB, JBFIN IFR8 = IFR_ini8+(K-JBDEB)*NCB DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) #if defined(RHSCOMP_BYROWS) WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(IPOSINRHSCOMP,K) #endif #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP)=ZERO #else RHSCOMP(IPOSINRHSCOMP,K)=ZERO #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (KEEP(201).EQ.1) 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 (KEEP(50).NE.0) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), NPIV, WCB(PPIV_COURANT), & NPIV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1) THEN CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV ) #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), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm('L','L','N','N',NPIV, NRHS_B, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV) #if defined(MUMPS_USE_BLAS2) ENDIF #endif END IF END IF 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 ( NPIV .NE. 0 .AND. NUPDATE.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), & NPIV, WCB(PPIV_COURANT), 1, ONE, & WCB(PCB_COURANT), 1) ELSE #endif CALL zgemm('T', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), & LIELL, WCB(PPIV_COURANT), 1, & ONE, WCB(PCB_COURANT), 1 ) ELSE #endif CALL zgemm('N', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF END IF IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN IF (KEEP(350).EQ.0) THEN DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + int(K-JBDEB,8)*int(LD_WCBPIV,8) #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1) = #else RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1,K) = #endif & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN #if defined(RHSCOMP_BYROWS) !$ OMP_FLAG = (NPIV.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8,K) IF (OMP_FLAG) DO I=1,NPIV IFR8 = PPIV_COURANT + I-1 DO K=JBDEB,JBFIN RHSCOMP(K,IPOSINRHSCOMP+I-1) = & WCB(IFR8+(K-JBDEB)*LD_WCBPIV) ENDDO ENDDO !$OMP END PARALLEL DO #else !$ 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 #endif ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1) THEN LDAJ = TempNROW ELSE LDAJ = NPIV ENDIF APOS1 = APOS JJ = J1 IF (KEEP(201).EQ.1) THEN NBK = 0 ENDIF IF (KEEP(350).EQ.0) THEN DO IF(JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF(IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV #else RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV #endif END DO IF (KEEP(201).EQ.1) 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) THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1) 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 DO K=JBDEB, JBFIN POSWCB1 = IFR8+int(K-JBDEB,8)*int(LD_WCBPIV,8) POSWCB2 = POSWCB1+1_8 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #endif END DO IF (KEEP(201).EQ.1) 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 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1) 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 ) #if defined(RHSCOMP_BYROWS) RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = & WCB( IFR8 ) * VALPIV #else RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV #endif IF (KEEP(201).EQ.1) 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) THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1) 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #endif IF (KEEP(201).EQ.1) 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 ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF END IF IF (KEEP(201).GT.0) 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 END IF FPERE = DAD(STEP(INODE)) IF ( FPERE .EQ. 0 ) THEN MYROOT = MYROOT - 1 PLEFTWCB = PLEFTWCB - LIELL *NRHS_B IF ( MYROOT .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 GO TO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 IF (KEEP(350).EQ.0) THEN !$ OMP_FLAG = .FALSE. !$OMP PARALLEL DO PRIVATE(K,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) DO 190 I = 1, NUPDATE IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & RHSCOMP( K, IPOSINRHSCOMP_TMP ) #else RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) #endif & + WCB(PCB_COURANT + I-1 +(K-JBDEB)*LD_WCBCB) ENDDO 190 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NUPDATE*(JBFIN-JBDEB+1) .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 IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & RHSCOMP( K, IPOSINRHSCOMP_TMP ) #else RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) #endif & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE IF ( PTRICB(STEP(INODE)) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 ENDIF END IF ELSE PTRICB(STEP( INODE )) = -1 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 ENDIF 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)), SLAVEF), & 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, III, 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 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) GOTO 260 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, III, 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 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) GOTO 260 END IF END DO END IF PLEFTWCB = PLEFTWCB - LIELL*NRHS_B 270 CONTINUE RETURN 260 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_SOLVE_NODE RECURSIVE SUBROUTINE ZMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, III, 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, III, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 40 ), 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) #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8) RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) #endif LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN DOUBLE PRECISION :: TIME_TMP 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 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, III, 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 MUMPS_5.1.2/src/dana_aux_par.F0000664000175000017500000027547613164366264016304 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, POINTER :: WORK1(:), WORK2(:), & 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 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 CALL DMUMPS_DO_PAR_ORD(id, ord, WORK2) 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) 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%KEEP(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 CALL DMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), & NFSIZ(1), 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 CALL DMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), NFSIZ(1), & 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, WORKERS #if defined(parmetis) || defined(parmetis3) INTEGER :: I, COLOR, BASE 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, POINTER :: 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, POINTER :: 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(MUMPS_GETSIZE(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, POINTER :: 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(MUMPS_GETSIZE(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 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)) 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) 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, POINTER :: 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(MUMPS_GETSIZE(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 = .TRUE. 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 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) 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=1, TOPNODES(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 INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR)) 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 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)) 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)) 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 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 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)) 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)) 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 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1)) 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) 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 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)) ALLOCATE(RCVBUF(2*BUFSIZE)) ALLOCATE(PENDING(NPROCS), CPNT(NPROCS)) ALLOCATE(REQ(NPROCS)) 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)) 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 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_COPY_INT_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_COPY_INT_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_COPY_INT_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_COPY_INT_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_COPY_INT_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_COPY_INT_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_COPY_INT_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_COPY_INT_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_COPY_INT_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_COPY_INT_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_COPY_INT_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_COPY_INT_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.1.2/src/sana_lr.F0000664000175000017500000003527613164366263015270 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1)) 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)) 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 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) :: LRGROUPS(N), VLIST(NV), TRACE(N) 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 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, INTENT(INOUT) :: LRGROUPS(N) INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1)) NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO PARTPTR(1)=1 CNT = 0 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 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 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 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 INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP)) ALLOCATE(PERM(NSEP)) ALLOCATE(IPERM(NSEP)) ALLOCATE(SIZES(NPARTS)) ALLOCATE(PARTPTR(NPARTS+1)) 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)) 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 END MODULE SMUMPS_ANA_LR MUMPS_5.1.2/src/dana_LDLT_preprocess.F0000664000175000017500000007076613164366263017643 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER N,NCST INTEGER PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N,3) INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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,1) IF(K1 .GT. 0) THEN V1 = (abs(id%A(K1))*(id%ROWSCA(P1)**2).GE.1.0D-1) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2,1) IF(K2 .GT. 0) THEN V2 = (abs(id%A(K2))*(id%ROWSCA(P2)**2).GE.1.0D-1) 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) 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(40) 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) 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.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) 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 & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(40) 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) 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 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE 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 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.1.2/src/dfac_determinant.F0000664000175000017500000001404113164366263017123 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.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 MUMPS_5.1.2/src/zfac_process_band.F0000664000175000017500000002364613164366265017316 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & TNBPROCFILS, N, IW, LIW, A, LA, & 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 #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(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & TNBPROCFILS( 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 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 ) IBUFR = 10 #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, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, 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+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 TNBPROCFILS(STEP( INODE )) = NBPROCFILS # if ! defined(NO_XXNBPR) IW(IWPOSCB+1+XXNBPR)=NBPROCFILS # endif IW(IWPOSCB+1+XXLR)=LRSTATUS 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' INTEGER, INTENT(IN) :: INODE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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)), & SLAVEF ) # 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, & NBPROCFILS, N, IW, LIW, A, LA, & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/zmumps_lr_data_m.F0000664000175000017500000005411613164366266017203 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_PANEL_LORU, & ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & ZMUMPS_BLR_RETRIEVE_PANEL_L, & ZMUMPS_BLR_RETRIEVE_PANEL_LORU, & ZMUMPS_BLR_DEC_AND_TRYFREE_L, & ZMUMPS_BLR_TRY_FREE_PANEL, & ZMUMPS_BLR_FREE_ALL_PANELS, & ZMUMPS_BLR_FREE_PANEL TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(lrb_type), pointer :: LRB_PANEL(:) END TYPE blr_panel_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 INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333) 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) 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) ENDDO RETURN END SUBROUTINE ZMUMPS_BLR_INIT_MODULE SUBROUTINE ZMUMPS_BLR_END_MODULE(INFO1, KEEP8, IS_FACTOR) INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: I, ILOOP IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF ILOOP=0 DO I=1, size(BLR_ARRAY) ILOOP= ILOOP+1 IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U)) THEN IF (INFO1 .GE.0) THEN WRITE(*,*) "Internal error 2 in MUMPS_BLR_END_MODULE ", & " IWHANDLER=", I CALL MUMPS_ABORT() ELSE CALL ZMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, IS_FACTOR) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE ZMUMPS_BLR_END_MODULE SUBROUTINE ZMUMPS_BLR_INIT_FRONT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error in ZMUMPS_BLR_INIT_FRONT ", & NB_PANELS ENDIF CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) 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 RETURN 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) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) ELSE ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (associated(BEGS_BLR_COL)) THEN INFO(2)=size(BEGS_BLR_L)+size(BEGS_BLR_COL) ELSE INFO(2)=size(BEGS_BLR_L) ENDIF RETURN ENDIF ELSE IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(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_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN INFO(2)=NB_PANELS+size(BEGS_BLR_L)+size(BEGS_BLR_COL) ELSE IF (IsSYM) THEN INFO(2)=NB_PANELS+size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+size(BEGS_BLR_L) ENDIF RETURN 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 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 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_INIT_FRONT SUBROUTINE ZMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, & KEEP8, IS_FACTOR) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) THEN RETURN 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) THEN WRITE(*,*) " Internal Error 2 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, IS_FACTOR) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF ENDIF ENDDO NULLIFY(THEPANEL%LRB_PANEL) 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) THEN WRITE(*,*) " Internal Error 2 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, IS_FACTOR) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF ENDIF ENDDO NULLIFY(THEPANEL%LRB_PANEL) IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF ENDIF IF (.NOT. associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER CALL MUMPS_ABORT() ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) 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 CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) 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 ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 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_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_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_PANEL_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_RETRIEVE_PANEL_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_RETRIEVE_PANEL_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_RETRIEVE_PANEL_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_RETRIEVE_PANEL_L 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", & "IPANEL=", IPANEL 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", & "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_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF 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 ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 2 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(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_U(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT - 1 ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE ZMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8, IS_FACTOR) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR 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, IS_FACTOR) RETURN END SUBROUTINE ZMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE ZMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE ZMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO 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 (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_FREE_ALL_PANELS SUBROUTINE ZMUMPS_BLR_FREE_PANEL( IWHANDLER, LORU, IPANEL, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: LORU INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF (LORU.EQ.0.or.LORU.EQ.1) THEN IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ELSE 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_FREE_PANEL END MODULE ZMUMPS_LR_DATA_M MUMPS_5.1.2/src/sfac_scalings_simScale_util.F0000664000175000017500000011743413164366266021325 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/mumps_print_defined.F0000664000175000017500000000343313164366241017666 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(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 write(MPG,*) "=================================================" RETURN END SUBROUTINE MUMPS_PRINT_IF_DEFINED MUMPS_5.1.2/src/sana_mtrans.F0000664000175000017500000007637413164366266016166 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/dfac_front_LDLT_type2.F0000664000175000017500000006561513164366264017721 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NOFFW, & NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'dmumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 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(40), 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), & 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)), NBPROCFILS(KEEP(28)), & 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 INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTBL, LR_ACTIVATED 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 HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER PIVOT_OPTION 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(BLR_L) IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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 PIVOT_OPTION = MIN(2,KEEP(468)) IF (UUTEMP == 0.0D0 .AND. KEEP(201).NE.1) THEN 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 IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. NULLIFY(BEGS_BLR) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) 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 K263 = 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 IF (KEEP(201).EQ.1) THEN IDUMMY = -9876 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 CNT_NODES = CNT_NODES + 1 CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL SYSTEM_CLOCK(TTOT1FR) ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.2) PIVOT_OPTION=2 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 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 IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) 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,NOFFW,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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IF (IFLAG.LT.0) GOTO 490 IF(KEEP(109).GT. 0) THEN IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN IWPOSPIV = IOLDPS+IW(IOLDPS+1+XSIZE)+6 & +IW(IOLDPS+5+XSIZE) PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+XSIZE) ENDIF ENDIF IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN NPVW = NPVW + PIVSIZ IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. & ( (KEEP(485).EQ.0) .AND. (PIVOT_OPTION.GT.2) ) & ) & ) 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,IEND_BLR,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & PIVOT_OPTION, .FALSE.) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 2, 1) ENDIF IF (LR_ACTIVATED) THEN 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 GOTO 101 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V', 2) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 ENDIF 101 CONTINUE 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8,PIVOT_OPTION, .TRUE.) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) CALL MUMPS_ABORT() #if defined(BLR_MT) !$OMP PARALLEL #endif IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 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(8), KEEP(477) & ) IF (IFLAG.LT.0) GOTO 450 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 100 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (PIVOT_OPTION.LE.2) THEN CALL SYSTEM_CLOCK(T1) CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & NASS, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) ELSE IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & NASS, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) END IF ENDIF CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 (KEEP(201).EQ.1) 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 500 480 CONTINUE write(*,*) 'Allocation problem in BLR routine & DMUMPS_FAC_FRONT_LDLT_TYPE2: ', & 'not enough memory? memory requested = ' , IERROR 490 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, 1, INODE, & NELIM) CALL STATS_COMPUTE_FLOP_FRONT_TYPE2(NFRONT, NASS, KEEP(50), & INODE, NELIM) CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), & 2) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) 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.1.2/src/cana_dist_m.F0000664000175000017500000007511413164366264016106 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, & NA, LNA, NE, DAD, ND, PROCNODE, SLAVEF, & NRLADU, NIRADU, NIRNEC, NRLNEC, & NRLNEC_ACTIVE, & NIRADU_OOC, NIRNEC_OOC, & MAXFR, OPSA, & KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND, SBUF_REC, 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 & ) IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER MYID, N, LNA, IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE 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), NA(LNA), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) 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, SBUF_REC 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, IPOOL, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR LOGICAL OUTER_SENDS_FR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER SBUFR, SBUFS INTEGER BLOCKING_RHS INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, NBROOT, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB, & LKJIBT, NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL COMPRESSCB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART 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 INTEGER MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_MAX_SURFCB_NBROWS, MUMPS_BLOC2_GET_NSLAVESMAX 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 COMPRESSCB=( 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), IPOOL(NSTEPS), & LSTKI(NSTEPS) , stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 4*NSTEPS RETURN endif LKJIB = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0) IF ( OUTER_SENDS_FR ) THEN LKJIB = max(LKJIB, KEEP(420)) ENDIF IF ( KEEP(486).NE.0 ) THEN LKJIB = max(LKJIB,KEEP(488)) ENDIF TNSTK = NE LEAF = NA(1)+1 IPOOL(1:LEAF-1) = NA(3:3+LEAF-2) NBROOT = NA(2) #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 = 0_8 ISTKI = 0 ISTKI_OOC = 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 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 NRLNEC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 ITOP = 0 MAXTEMPCB = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS = 1 SBUFR_CB = 1_8 SBUFR = 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 IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),SLAVEF) & .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 WRITE(MYID+6,*) ' ERROR 1 in CMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() 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)),SLAVEF) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),SLAVEF) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & SLAVEF) 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. COMPRESSCB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 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 & ) 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 NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & int(LOCAL_M,8)*int(LOCAL_N,8)) NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) 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)), SLAVEF)) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) 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 = max(SBUFS, NFR*LKJIB+LKJIB+4) ELSE SBUFS = max(SBUFS, NELIM*LKJIB+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR = max(SBUFR, NFR*LKJIB+LKJIB+4) else SBUFR = max( SBUFR, NELIM*LKJIB+NELIM+6 ) IF (KEEP(50).EQ.1) THEN LKJIBT = LKJIB ELSE LKJIBT = min( NELIM, LKJIB * 2 ) ENDIF SBUFS = max(SBUFS, & LKJIBT*NBROWMAX+6) SBUFR = max( SBUFR, NBROWMAX*LKJIBT+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 SIZECBI = 2* NCB + 6 + 3 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 MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECBI = NCB + 5 + 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) NRLADU = NRLADU + NRLADU_CURRENT ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) NRLADU = NRLADU + NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECBI = 4 + NBROWMAX + NCB 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 (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 (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 = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) ENDIF 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 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)),SLAVEF) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),SLAVEF) 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 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)), & SLAVEF) .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 NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF 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)),SLAVEF) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)),SLAVEF).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) ELSE NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) ENDIF 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) 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) 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. COMPRESSCB)) 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 * NFR + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.COMPRESSCB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN SIZECBI = 2+ XSIZE_IC ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) 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)) SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) SIZECBI = 0 SIZECB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE 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 SIZECBI = NCB + 5 + SLAVEF - 1 + XSIZE_IC SIZECB = 0_8 ELSE IF (UPDATE) THEN SIZECBI = NFR + 6 + SLAVEF - 1 + XSIZE_IC IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 SIZECBI = 0 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (COMPRESSCB) 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 = NCB + 5 + SLAVEF - 1 + XSIZE_IC ELSE SIZECB = SIZECB_SLAVE SIZECBI = 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) ) 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 BLOCKING_RHS = KEEP(84) IF (KEEP(84).EQ.0) BLOCKING_RHS=1 NRLNEC = max(NRLNEC, & NRLADU+int(4*KEEP(127)*abs(BLOCKING_RHS),8)) IF (BLOCKING_RHS .LT. 0) THEN BLOCKING_RHS = - 2 * BLOCKING_RHS ENDIF NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(4*KEEP(127)*BLOCKING_RHS,8)) SBUF_RECOLD = max(int(SBUFR,8),SBUFR_CB) SBUF_RECOLD = max(SBUF_RECOLD, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC = max(SBUFR, int(min(100000_8,SBUFR_CB))) SBUF_REC = SBUF_REC + 17 SBUF_REC = SBUF_REC + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND = max(SBUFS, int(min(100000_8,SBUFR_CB))) SBUF_SEND = SBUF_SEND + 17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC = SBUF_REC+KEEP(108)+1 SBUF_SEND = SBUF_SEND+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC = 1 SBUF_SEND= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, IPOOL, & LSTKI ) OPS_SUBTREE = real(OPS_SBTR_LOC) OPSA = real(OPSA_LOC) KEEP(66) = int(OPSA_LOC/1000000.d0) RETURN END SUBROUTINE CMUMPS_ANA_DISTM MUMPS_5.1.2/src/cfac_process_blocfacto_LDLT.F0000664000175000017500000010613613164366264021131 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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_OOC USE CMUMPS_LR_CORE USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_FAC_LR USE CMUMPS_ANA_LR USE CMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ), 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), 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 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL, LD_BLOCFACTO INTEGER(8) LAELL, POSBLOCFACTO INTEGER(8) POSELT 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 INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW 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(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPivDummy LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRELAY_INFO LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR LOGICAL :: SEND_LR INTEGER :: XSIZE, CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: SEND_LR_INT, 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 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL 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 INTEGER T1, T2, COUNT_RATE, LWORK REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, MY_NUM 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF 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 ( SEND_LR ) THEN LAELL = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LAELL = int(NPIV,8) * int(NCOL,8) ENDIF IF ( NPIV.GT.0 ) THEN IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS, IERROR) IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN CMUMPS_PROCESS_SYM_BLOCFACTO, & REAL WORKSPACE TOO SMALL" GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress CMUMPS_PROCESS_SYM_BLOCFACTO,", & " LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS,IERROR) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN CMUMPS_PROCESS_SYM_BLOCFACTO, & INTEGER WORKSPACE TOO SMALL" IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(70) = KEEP8(70) - LAELL KEEP8(71) = KEEP8(71) - LAELL ENDIF KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLUS) IF ( NPIV.EQ.0 ) THEN IPIV = 1 LD_BLOCFACTO = NPIV+NELIM ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR ) 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_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1))) ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2)) CALL CMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, KEEP(470), & BEGS_BLR_LM(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 SRC_DESCBAND = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTRIST(STEP(INODE))+XXNBPR)) DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) #else DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) POSELT = PTRAST(STEP(INODE)) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) ELSE CALL CMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS) 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 PIVI = abs(IW(IPIV+I-1)) 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(IPOS), NCOL1, A(KPOS), NCOL1) ENDDO IF (.NOT.SEND_LR) 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 (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T1) ENDIF CALL ctrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A(POSELT+int(NPIV1,8)), NCOL1 ) IF (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_TRSM_TIME = ACC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF IF (.NOT.SEND_LR) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 DO I = 1, NROW1 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = & A(LPOS: LPOS+int(NPIV-1,8)) LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF LPOS = POSELT + int(NPIV1,8) DPOS = POSBLOCFACTO I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(IPIV+I-1) .GT. 0) THEN A11 = ONE/A(DPOS) CALL cscal( NROW1, A11, A(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 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A11*A(LPOS1)+A12*A(LPOS1+1_8) MULT2 = A12*A(LPOS1)+A22*A(LPOS1+1_8) A(LPOS1) = MULT1 A(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 IF (SEND_LR) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 ENDIF IF (NPIV.GT.0) THEN IF (NROW1.LE.0) CALL MUMPS_ABORT() IF (SEND_LR) 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 (KEEP(489).EQ.1) 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 ELSE CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_MASTER ENDIF CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL) 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 CALL CMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), & .TRUE., .TRUE., .TRUE., NPARTSASS_MASTER, & 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)) write(6,*) 'ERROR 2 allocate temporary BLR blocks during', & ' CMUMPS_PROCESS_SYM_BLOCFACTO', IERROR GOTO 700 ENDIF CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS)) CALL SYSTEM_CLOCK(T1) MY_NUM=0 #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, DKEEP(8), KEEP(473), BLR_LS, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #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. & ( .NOT. SEND_LR .OR. (NPIV.EQ.0) .OR. & (KEEP(485).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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN IF (SEND_LR) THEN IF (NELIM.GT.0) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL cgemm('N','N', NELIM,NROW1,NPIV,ALPHA, & A(UPOS),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ENDIF #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL CMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL1, NROW1, & POSBLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM+1, BLR_LM, NPIV1, & BEGS_BLR_LS, NB_BLR_LS+1, BLR_LS, 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR(1:MAXI_CLUSTER,MY_NUM*MAXI_CLUSTER+1), & MAXI_CLUSTER, & KEEP(481), DKEEP(8), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_UPDT_TIME = ACC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_LS, & 0, NPARTSCB, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, & .FALSE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS, & CURRENT_BLR, 'V', NCOL1, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (KEEP(201).eq.1) 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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF ENDIF CALL DEALLOC_BLR_PANEL (BLR_LM, NB_BLR_LM, KEEP8, .FALSE.) DEALLOCATE(BLR_LM) IF (NSLAVES_PREC.GT.0) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL,BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF ELSE LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL cgemm('N','N', NCOL-NPIV,NROW1,NPIV,ALPHA,A(UPOS),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) DPOS = POSELT + int(NCOL1 - NROW1,8) 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( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A(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( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, ONE, & A( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO 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. SEND_LR ) THEN LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) 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 ) CALL CMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & SEND_LR, BLR_LS, IPANEL, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 defined(IBC_TEST) WRITE(*,*) MYID,":Send2slave worked" #endif 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 ( NPIV.GT. 0 .AND. SEND_LR ) THEN IF (NSLAVES_PREC.GT.0) THEN IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8, .TRUE.) ENDIF LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( NPIV .NE. 0 ) THEN IF (allocated(UIP21K)) DEALLOCATE( UIP21K ) ENDIF IOLDPS = PTRIST(STEP(INODE)) IF (LASTBL) THEN IF (KEEP(486).NE.0) THEN IF (SEND_LR) 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)), SLAVEF ) 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 (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN CALL CMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, & BEGS_BLR_COL, NB_BLR_COL, NPARTSASS_MASTER, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., 0, KEEP(484)) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 (SEND_LR) 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, .TRUE.) 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 (KEEP(489).EQ.1) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if defined(IBC_TEST) write(6,*) MYID,' :Exiting CMUMPS_PROCESS_SYM_BLOCFACTO for &INODE=', INODE #endif RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.1.2/src/mumps_io_err.h0000664000175000017500000000305713164366240016376 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/src/sfac_root_parallel.F0000664000175000017500000001513213164366263017471 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_FACTO_ROOT( 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) USE SMUMPS_LR_STATS, ONLY: UPDATE_FLOPS_STATS_ROOT IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' TYPE ( SMUMPS_ROOT_STRUC ) :: root 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 IOLDPS INTEGER(8) :: IAPOS 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 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 UPDATE_FLOPS_STATS_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 UPDATE_FLOPS_STATS_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,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 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, DKEEP(6), KEEP(259), & 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.1.2/src/zfac_scalings.F0000664000175000017500000002751413164366265016455 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), INFO(40) 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(OUT) :: 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.1.2/src/darrowheads.F0000664000175000017500000006767313164366263016162 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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( 40 ) 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 INTEGER(8) :: IPTRI, IPTRR 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), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), SLAVEF ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), SLAVEF ) 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 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), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), SLAVEF ) 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. 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 ) IMPLICIT NONE INCLUDE 'dmumps_root.h' 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,INEW,JNEW,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 TYPENODE_TMP, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: I1, IA, IIW, IS1, IS, IAS, ISHIFT, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, POINTER, DIMENSION(:,:) :: IW4 ARROW_ROOT = 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 ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER(int(I-1,8)*int(root%SCHUR_LLD,8)+1_8: & int(I-1,8)*int(root%SCHUR_LLD,8)+int(root%SCHUR_MLOC,8))= & ZERO ENDDO ENDIF 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 DO 120 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 GOTO 120 END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF 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 ENDIF ENDIF IARR = abs( ISEND ) ISTEP = abs( STEP(IARR) ) TYPENODE_TMP = MUMPS_TYPENODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE = MUMPS_PROCNODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & SLAVEF ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF (TYPENODE_TMP.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) 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 IF ( TYPENODE_TMP .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPENODE_TMP .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 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 )/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 END IF 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 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPENODE_TMP .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 IIW = IS1 + ISHIFT + 2_8 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = 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 ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 .OR. .TRUE.) & .AND. IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF (MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) == 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 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)) END IF 120 CONTINUE 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 & ) IMPLICIT NONE INCLUDE 'dmumps_root.h' 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 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 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) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I=1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC)=ZERO ENDDO ENDIF 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)))), & SLAVEF ) .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 .OR. .TRUE.) & .AND. IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) 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 MUMPS_5.1.2/src/zfac_lastrtnelind.F0000664000175000017500000001750413164366265017353 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)),SLAVEF) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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( .FALSE.,MYID,N, IPOS_SON, & PTRAST(STEP(IN)), & 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.1.2/src/fac_ibct_data_m.F0000664000175000017500000000073713164366241016676 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zsol_driver.F0000664000175000017500000065616513164366266016224 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_SOLVE_DRIVER(id) USE ZMUMPS_STRUC_DEF USE MUMPS_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 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,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK 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 MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL 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(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSCOMP INTEGER :: PERM_PIV_LIST(max(id%KEEP(112),1)) INTEGER :: MAP_PIVNUL_LIST(max(id%KEEP(112),1)) 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_PIV_LIST permuted array of pivots C MAP_PIVNUL_LIST: mapping of permuted list 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(:) 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_IN_RHSCOMP_F, & NB_FS_IN_RHSCOMP_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV 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.0 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 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 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_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 WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE 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) IS_INIT_OOC_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)) 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. 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_IN_RHSCOMP_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_IN_RHSCOMP_F = NB_FS_IN_RHSCOMP_TOT 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 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 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 in fact effectively C -- 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 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 WRITE(6,*) " WARNING !!! A-1 OFF and KEEP(242)= ", & KEEP(242), " is reset to zero (OFF)" C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder ELSE KEEP(242) = 0 ! no permutation ENDIF 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 id%KEEP(243)=0 id%KEEP(495)=0 IF (id%KEEP(235) .EQ. 1) THEN IF (id%KEEP(497).EQ.-1) 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 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(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 ISOL_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) WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' 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) WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' 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) WRITE(MPG,'(A)') & ' ERROR: id%NRHS not allowed to change when ICNTL(32)=1' 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) WRITE(MPG,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' 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) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE INFO(2) = 20 ! ICNTL(20) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: sparse RHS incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS 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 ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 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),MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 IF (KEEP(111).eq.-1.AND.id%NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=id%NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. id%NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=id%NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN C Ignore sparse RHS in case we compute C vectors of the null space (KEEP(111)).NE.0.) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! icntl(30) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ELSE IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' INFO(2) = 20 ! inclt(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 END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21==1) THEN IF ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) 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 (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, LSCAL ) 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((J-1)*id%LRHS + I) =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 ) & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30) 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 MUMPS_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 #if defined(RHSCOMP_BYROWS) C In case of row storage with reduced right hand side, we C do not take into account empty columns during forward. C Therefore NRHS_NONEMPTY will simply be set to id%NRHS & .AND. KEEP(221) .NE. 1 #endif & ) 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))), & id%NSLAVES ) 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))), & id%NSLAVES ) 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 C Avoid to have overflows in NFRONT * NBRHS C 32-bit integer compuitations. C Should be hopefully large-enough for a while. IF(huge(NBRHS)/id%KEEP(133).LT.NBRHS) THEN IF (PROKG) WRITE(MPG,'(A,I6,A)')'Warning: NBRHS = ',NBRHS, & ' might be too large.' NBRHS = huge(NBRHS)/id%KEEP(133)-1 ! -1 to avoid rounding pbs IF (PROKG) WRITE(MPG,'(A,I6)')'NBRHS reset to ',NBRHS END IF 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 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 (id%MYID.EQ.MASTER) THEN IF ( PROKG ) THEN WRITE( MPG, 150 ) & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30) 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).OR.(KEEP(237).NE.0).OR. & (KEEP(252).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)') & ' WARNING: Incompatible features: null space basis ', & ' 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)') & ' 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)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' 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) & WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' INFO(1) = -13 INFO(2) = id%N*NBRHS GOTO 111 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 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(111),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_SOLVE = ( 4 + KEEP(133) ) * KEEP(34) + & KEEP(133) * NBRHS * KEEP(35) & + 16 * KEEP(34) ! for request id, pointer to next + safety C -------------------------------------- C Compute an upperbound of message size C for ZMUMPS_GATHER_SOLUTION C -------------------------------------- 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) 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 MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for ZMUMPS_GATHER_SOLUTION id%LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) id%LBUFR_BYTES = max(id%LBUFR_BYTES,TSIZE) id%LBUFR = ( id%LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) IF ( associated (id%BUFR) ) THEN NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) ENDIF ALLOCATE (id%BUFR(id%LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) & WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' INFO(1) = -13 INFO(2) = id%LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(id%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) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C CALL MPI_BCAST(KEEP(497),1,MPI_INTEGER,MASTER, & id%COMM,IERR) 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) & WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on a slave' 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 = 3 * KEEP(28) + 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) 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 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 IF ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) 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 solution C ------------------------------------- IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN C In case of scaling we will need to scale C back the RHS. 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 40 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data%SCALING=>id%ROWSCA ENDIF IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%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 40 ENDIF NB_BYTES = NB_BYTES + int(id%KEEP(89),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF 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, LSCAL ) 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 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 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 CALL MUMPS_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 MUMPS_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 C Phase 1 : ZMUMPS_PERMUTE_RHS_NS C local permutations to minimize sequential disk access C with chunck of size KEEP(84)/NSLAVES C Phase 2 : ZMUMPS_SOL_APPLY_PARPERM C parallel redistribution to exploit // disk access feature IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C Phase 1 to be called on each proc 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) THEN IF ( KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ELSE 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 MUMPS_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(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 / NS ENDIF ! End 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 defined(RHSCOMP_BYROWS) C In case RHSCOMP is stored by rows, we need to ensure C that the blocks during forward and backward are the C same. For that, a simple and safe solution consists in C avoiding skipping empty columns during the forward step. IF (KEEP(221).NE.1) THEN #endif 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((PERM_RHS(JBEG_RHS) -1)*LD_RHS+I) & = 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((JBEG_RHS -1)*LD_RHS + I) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN C Reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR #if defined(RHSCOMP_BYROWS) ENDIF C In that case we will have NB_RHSSKIPPED=0 C and we have JBEG_RHS = JEND_RHS+1 IF (KEEP(221).EQ.1) THEN IF ( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) THEN DO J=JBEG_RHS, JBEG_RHS + NBRHS_EFF -1 DO I=1, id%SIZE_SCHUR id%REDRHS((J-1)*LD_REDRHS + I) = ZERO ENDDO ENDDO ENDIF ENDIF #endif 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 #if defined(RHSCOMP_BYROWS) C In case of forward-only, we do not skip empty RHS. C This would cause problems during the backward phase: since C each block of RHSCOMP has a row-major storage and inside C each block, data is congiguous, blocks must be the same C during forward and during backward. Hence NB_RHSSKIPPED C will be 0. C & .OR. KEEP(221) .EQ. 1 #endif & ) 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 defined(RHSCOMP_BYROWS) IF (NZ_THIS_BLOCK .eq. 0) THEN C Skip block, C set REDRHS, RHSCOMP will be set later IF (KEEP(221).EQ.1) THEN DO J=JBEG_RHS, JBEG_RHS+ NBRHS_EFF -1 DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDDO ELSE WRITE(*,*) "Internal error 15 is sol_driver" CALL MUMPS_ABORT() ENDIF ENDIF #else IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF #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).NE.0) ) 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 ========================================================== 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).EQ.0 .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 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_IN_RHSCOMP_TOT ) NB_FS_IN_RHSCOMP_F = NB_FS_IN_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_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT, & UNS_PERM_INV, size(UNS_PERM_INV) ! size 1 if not used & ) ENDIF ENDIF ! BUILD_POSINRHSCOMP=.TRUE. 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 #if defined(RHSCOMP_BYROWS) C Stored by rows but only inside each C block. We keep IBEG_RHSCOMP unchanged C for locality since both SCATTER_RHS and C GATHER_SOLUTION will be done block-by-block? IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 #else IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 #endif 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 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 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 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 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(PERM_RHS(I)) * & 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(PERM_RHS(I))+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+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 IF(id%MYID.EQ.MASTER) 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_IN_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 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, * - to build Ej and store it in RHSCOMP K=1 ! Column index in RHSCOMP id%RHSCOMP(1:NBRHS_EFF*LD_RHSCOMP) = 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_IN_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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP((IPOSRHSCOMP-1)*NBRHS_EFF+K) = & RHS_SPARSE_COPY(IPOS) #else id%RHSCOMP((K-1)*LD_RHSCOMP+IPOSRHSCOMP) = & RHS_SPARSE_COPY(IPOS) #endif 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 #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error 17 is sol driver" CALL MUMPS_ABORT() #else DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, LD_RHSCOMP id%RHSCOMP((K-1)*LD_RHSCOMP + I) = ZERO ENDDO ENDDO #endif ENDIF #if defined(RHSCOMP_BYROWS) IF (I_AM_SLAVE) THEN DO I=1, NBENT_RHSCOMP DO K = 1, NBCOL_INBLOC C NBCOL_INBLOC is equal to NBRHS_EFF in this case id%RHSCOMP(IBEG_RHSCOMP+ & int(I-1,8)*int(NBRHS_EFF,8)+int(K-1,8))=ZERO ENDDO ENDDO ENDIF C Test below must be done also on non-working host !! IF (NZ_THIS_BLOCK .EQ. 0 .AND. KEEP(221).EQ.1) THEN C Skip the rest, go to next block. GOTO 1000 ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = IBEG_RHSCOMP + int(K-1,8) #else 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 #endif 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_IN_RHSCOMP_TOT IF ( (IPOSRHSCOMP.LE.NB_FS_IN_RHSCOMP_TOT) & .AND.(IPOSRHSCOMP.GT.0) ) THEN C ! I is fully summed var mapped on my proc #if defined(RHSCOMP_BYROWS) id%RHSCOMP(KDEC+(IPOSRHSCOMP-1)*NBRHS_EFF)= & id%RHSCOMP(KDEC+(IPOSRHSCOMP-1)*NBRHS_EFF) + & RHS_SPARSE_COPY(IZ) #else id%RHSCOMP(KDEC+IPOSRHSCOMP)= & id%RHSCOMP(KDEC+IPOSRHSCOMP) + & RHS_SPARSE_COPY(IZ) #endif 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 IF (INTERLEAVE_PAR .AND.(id%NSLAVES .GT. 1) ) THEN IRHS_SPARSE_COPY(II) = PERM_PIV_LIST(I) ELSE IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) ENDIF 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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP(1:NBRHS_EFF*LD_RHSCOMP)=ZERO #else 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 #endif 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 IF ((KEEP(235).NE.0) .AND. INTERLEAVE_PAR) THEN C When the PIVNUL_LIST has been permuted (in PERM_PIV_LIST) C then to exploit sparsity RHSCOMP need be initialized with c some care; taking into acount the processor localisation C of the indices of the null pivots. DO I=IBEG_GLOB_DEF,IEND_GLOB_DEF C Local processor is concerned by I-th column of C global right-hand side. IF (id%MYID_NODES .EQ. MAP_PIVNUL_LIST(I) ) THEN JJ= id%POSINRHSCOMP_ROW(PERM_PIV_LIST(I)) IF (JJ.GT.LD_RHSCOMP) THEN WRITE(6,*) ' Internal Error 10 JJ, LD_RHSCOMP=', & JJ, LD_RHSCOMP ENDIF IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN C unsymmetric : always set to fixation used during facto C because during factorization we aimed at preserving the C sign of the diagonal element, sign here may be different C from sign of corresponding diagonal element (not critical) #if defined(RHSCOMP_BYROWS) id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)* int(NBRHS_EFF,8)) = #else id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8)) = #endif & cmplx(abs(id%DKEEP(2)),kind=kind(id%RHSCOMP)) ELSE #if defined(RHSCOMP_BYROWS) id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8) *int(NBRHS_EFF,8)) = ONE #else id%RHSCOMP(IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8)) = ONE #endif ENDIF ENDIF ENDIF ENDDO ELSE 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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)*int(NBRHS_EFF,8) ) = #else id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8) ) = #endif & cmplx(id%DKEEP(2),kind=kind(id%RHSCOMP)) ELSE ! Symmetric: always set to one #if defined(RHSCOMP_BYROWS) id%RHSCOMP( IBEG_RHSCOMP+int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)*int(NBRHS_EFF,8) )= #else id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8)+ & int(JJ-1,8) )= #endif & ONE ENDIF ENDIF ENDDO ENDIF ! exploit sparsity 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 IF(id%MYID.EQ.MASTER) THEN TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 ENDIF 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, & id%BUFR(1), id%LBUFR, id%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, & id%BUFR(1), id%LBUFR, id%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) C size 1 if not used & , UNS_PERM_INV, NB_FS_IN_RHSCOMP_F, NB_FS_IN_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 TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) 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 #if defined(RHSCOMP_BYROWS) LCWORK = NBRHS_EFF #else LCWORK = max(max(KEEP(247),KEEP(246)),1) #endif ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) 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 ) IF(id%MYID.EQ.MASTER) 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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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_IN_RHSCOMP_TOT & ) ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 ENDIF 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 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 COLSIZE = id%IRHS_PTR(PERM_RHS(J)+1) - & id%IRHS_PTR(PERM_RHS(J)) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 c IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PERM_RHS(J)), & id%IRHS_PTR(PERM_RHS(J)+1)-1 I = id%IRHS_SPARSE (IZ) DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN WRITE(6,*) " Internal Error 13 in solution ", & " driver, gather " CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ELSE ! Not (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 COLSIZE = id%IRHS_PTR(J+1) - id%IRHS_PTR(J) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 c IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(J), id%IRHS_PTR(J+1) - 1 I = id%IRHS_SPARSE (IZ) DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN WRITE(6,*) " Internal Error 14 in solution", & " driver, gather " CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR 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, 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 ) 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 ) 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 #if defined(RHSCOMP_BYROWS) 1000 CONTINUE #endif 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((PERM_RHS(JBEG_NEW) -1)*LD_RHS+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((JBEG_NEW -1)*LD_RHS + 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((PERM_RHS(JBEG_NEW) -1)*id%LSOL_LOC+I) & = 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((JBEG_NEW -1)*LD_REDRHS + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN #if defined(RHSCOMP_BYROWS) DO I=1,NBENT_RHSCOMP JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) id%RHSCOMP(JBEG_NEW + (I-1)*NBRHS_EFF) = ZERO JBEG_NEW = JBEG_NEW +1 ENDDO ENDDO #else JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSCOMP id%RHSCOMP((JBEG_NEW -1)*LD_RHSCOMP + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO #endif 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 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 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 IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Global statistics" WRITE( MPG, 434 ) id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) WRITE( MPG, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(116) ! non-zero if gather WRITE( MPG, 431 ) id%DKEEP(122) ! Distributed solution 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(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(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 (associated(id%BUFR)) THEN NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 DEALLOCATE(id%BUFR) NULLIFY(id%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%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%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 RHS (dist.sol)=',F15.6) 150 FORMAT(/' 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) 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_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_IN_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, id%BUFR(1), id%LBUFR, & id%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, C Case of special root node & 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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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.1.2/src/dmumps_driver.F0000664000175000017500000025533313164366266016532 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 -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, 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). These 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. * * 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. 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. * Other values for the parameter JOB can invoke combinations of these * three basic operations. 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_8) THEN id%KEEP8(29) = id%NNZ_loc ELSE id%KEEP8(29) = int(id%NZ_loc, 8) ENDIF ENDIF C C IF (JOB.EQ.-2.OR.JOB.EQ.1.OR.JOB.EQ.2.OR.JOB.EQ.3.OR. & JOB.EQ.4.OR.JOB.EQ.5.OR.JOB.EQ.6 & ) THEN C Correct value of JOB C ICNTL should have been initialized and can be used LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%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 (id%KEEP(500).EQ.1) THEN FROM_C_INTERFACE_STRING=" from C interface" ELSE FROM_C_INTERFACE_STRING=" " ENDIF IF (PROKG) THEN C Print basic information on MUMPS call IF (JOB .EQ. -2 & ) THEN C N, NELT, NNZ not meaningful WRITE(MPG,'(/A,A,A,A,I4,I12)') & 'Entering DMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB =', JOB ELSE IF (id%ICNTL(5) .NE. 1) THEN C Assembled format IF (id%ICNTL(18) .EQ. 0 & ) THEN WRITE(MPG,'(/A,A,A,A,I4,I12,I15)') & 'Entering DMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB, N, NNZ =', JOB,id%N,id%KEEP8(28) ELSE WRITE(MPG,'(/A,A,A,A,I4,I12)') & 'Entering DMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB, N =', JOB,id%N ENDIF ELSE C Elemental format WRITE(MPG,'(/A,A,A,A,I4,I12,I15)') & 'Entering DMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' driver with JOB, N, NELT =', JOB,id%N,id%NELT ENDIF C MPI and OpenMP information !$ IF (.TRUE.) THEN !$ WRITE(MPG, '(A,I6,A,I6)') ' executing #MPI = ', !$ & id%NPROCS, ' and #OMP = ', NOMP !$ IF ( NOMPMIN .NE. NOMPMAX ) THEN !$ WRITE(MPG, '(A,I4,A,I4,A)') !$ & ' WARNING detected: different number of threads (max ', !$ & NOMPMAX, ', min ', NOMPMIN, ')' !$ END IF !$ ELSE WRITE(MPG, '(A,I6,A)') ' executing #MPI = ', & id%NPROCS, ', without OMP' !$ ENDIF IF (JOB.GE.1 .AND. JOB.LE.6) THEN WRITE(MPG, '(A)') ENDIF ENDIF END IF C C---------------------------------------------------------------- C C JOB = -1 : START INITIALIZATION PHASE C (NEW INSTANCE) C C JOB = -2 : TERMINATE AN INSTANCE C---------------------------------------------------------------- C IF ( JOB .EQ. -1 ) THEN C C ------------------------------------------ C Check that we have called (JOB=-2), ie C that the previous JOB is not 1 2 or 3, C before calling the initialization routine. C -------------------------------------------- id%INFO(1)=0 id%INFO(2)=0 OLDJOB = id%KEEP( 40 ) + 456789 IF ( OLDJOB .EQ. 1 .OR. & OLDJOB .EQ. 2 .OR. & OLDJOB .EQ. 3 ) THEN IF ( id%N > 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---------------------------------------------------------------- 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----------------------------------------------------------------------- C TIMINGS IF (id%MYID .eq. MASTER) THEN id%DKEEP(70)=0.0D0 CALL MUMPS_SECDEB(TIMETOTAL) END IF OLDJOB = id%KEEP( 40 ) + 456789 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 IS1 :allocated on the master now, will be allocated on C the slaves later 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 IF (associated(id%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) ENDIF C ------------------------------------------- C Allocate array IS1 for analysis of size: C - assembled entry: 10 * N or 11 * N C depending on max-trans C - element entry: 7 * N + 3 * NELT + 3 C max-trans not allowed C ------------------------------------------- IF ( id%ICNTL(5) .NE. 1 ) THEN ! assembled matrix IF ( id%KEEP(50) .NE. 1 & .AND. ( & (id%ICNTL(6) .NE. 0 .AND. id%ICNTL(7) .NE.1) & .OR. & id%ICNTL(12) .NE. 1) ) THEN id%MAXIS1 = 7 * id%N ELSE id%MAXIS1 = 6 * id%N END IF ELSE id%MAXIS1 = 6 * id%N ENDIF ALLOCATE( id%IS1(id%MAXIS1), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%MAXIS1 IF ( LPOK ) WRITE(LP,'(A)') & ' Problem in allocating work array for analysis' GO TO 100 END IF C C ---------------------- C Allocate PROCNODE(1:N) C ---------------------- IF ( associated( id%PROCNODE ) ) & DEALLOCATE( id%PROCNODE ) ALLOCATE( id%PROCNODE(id%N), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%N IF ( LPOK ) WRITE(LP,'(A)') & 'Problem in allocating work array PROCNODE' GOTO 100 END IF id%PROCNODE(1:id%N) = 0 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. 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 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 ------------------------------------------- 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 CALL DMUMPS_ANA_DRIVER( id ) C Save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ELSE id%INFOG(33)=id%ICNTL(8) ENDIF 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 (id%MYID .eq. MASTER.AND.id%KEEP(492).EQ.0) THEN C No front to be selected for LR id%KEEP(486) = 0 IF (PROKG) & write(MPG,'(A)') " Low rank reset off since no front selected " 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), & id%SIZE_SCHUR*id%SIZE_SCHUR) 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( id%KEEP(52) .EQ. -2 .AND. id%ICNTL(8) .NE. -2 .AND. & id%ICNTL(8).NE. 77 ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** scaling already computed during analysis' WRITE(MPG,'(A)') & ' ** keeping the scaling from the analysis' ENDIF ENDIF IF (id%KEEP(52) .NE. -2) THEN 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 IF ( id%KEEP( 19 ) .ne. 0 .and. id%KEEP( 52 ).ne. 0 ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') ' ** (incompatibility with null space)' END IF id%KEEP(52) = 0 END IF 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 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) id%INFO(1)=-13 ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 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) id%INFO(1)=-13 IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 IF ( id%INFO(1) .eq. -13 ) THEN 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) 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), & id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) 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)) 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 (associated(id%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) ENDIF IF (associated(id%PROCNODE)) THEN DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) ENDIF #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) = TIMEG ENDIF 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 = 40 INTEGER :: INFO(40) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(40) 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 .and. INFO(2) .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 SUBROUTINE DMUMPS_PRINT_ICNTL(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 INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL 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) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 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,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) 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) WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) CASE(5); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(6); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 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) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 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 =',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 ( 0= off, else=on) =',I10/ & 'ICNTL(20) Dense (0) or sparse (1) 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) Dense (0) or sparse (1) 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 & (size(idRHS)<(idNRHS*idLRHS-idLRHS+idN)) & 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.1.2/src/mumps_type_size.F0000664000175000017500000000105413164366241017064 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zfac_process_contrib_type1.F0000664000175000017500000001054413164366265021165 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) 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(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 COMPRESSCB 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) COMPRESSCB = (FLCONT.LT.0) IF (COMPRESSCB) 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) IF (IPTRLU.LT.0_8) WRITE(*,*) 'before alloc_cb:IPTRLU = ',IPTRLU CALL ZMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, IFLAG, IERROR & ) IF (IPTRLU.LT.0_8) WRITE(*,*) 'after alloc_cb:IPTRLU = ',IPTRLU IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (COMPRESSCB) 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 (COMPRESSCB) 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 IF ( LREQCB .ne. 0_8 ) THEN IPOS_NODE = PAMASTER(STEP(FINODE))-1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + 1_8 + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR) END IF 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.1.2/src/cfac_determinant.F0000664000175000017500000001421113164366264017122 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.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 MUMPS_5.1.2/src/sfac_process_contrib_type3.F0000664000175000017500000002457413164366262021165 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS,SLAVEF ) USE SMUMPS_LOAD USE SMUMPS_OOC IMPLICIT NONE INCLUDE 'smumps_root.h' 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 ), NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)),SLAVEF REAL A( LA ) INTEGER MYID INTEGER FILS( N ) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N ) INTEGER INTARR(KEEP8(27)) REAL DBLARR(KEEP8(26)) 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 NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT))-1 #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) - 1 CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)),KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN #endif 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(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 NBPROCFILS(STEP( IROOT ) ) = -1 #if ! defined(NO_XXNBPR) KEEP(121)=-1 #endif ENDIF IF (KEEP(60) == 0) THEN CALL SMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N, & IW, LIW, A, LA, & FILS, MYID, 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 ELSE PTRIST(STEP(IROOT)) = -55555 ENDIF 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, PTRIST, & PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, 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 ) CALL SMUMPS_ASS_ROOT( 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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, PTRIST, & PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, 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 ) IF (KEEP(60).EQ.0) THEN CALL SMUMPS_ASS_ROOT( 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( 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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.1.2/src/cfac_front_aux.F0000664000175000017500000020324713164366265016627 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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,IOLDPS,POSELT,UU,SEUIL,KEEP, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER KEEP(500) 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 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 NOFFW,NPIV,IPIV,IPIV_SHIFT 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 !$ INTEGER :: JJMAX !$ REAL :: RRMAX, VALABS !$ INTEGER :: NOMP, CHUNK, K360 !$ K360 = KEEP(360) !$ NOMP = OMP_GET_MAX_THREADS() NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) 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)).GT.max(UU*MAXFROMN,SEUIL, & tiny(MAXFROMN))) 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 IF (KEEP(351).EQ.1) THEN !$ IF (NOMP.GT.1 .AND. J3.GE.K360) THEN !$ JMAX = 1 !$ RMAX = RZERO !$ CHUNK = max(K360/2,J3/NOMP) !$OMP PARALLEL PRIVATE(JJ,VALABS,JJMAX,RRMAX) !$OMP& FIRSTPRIVATE(J1,NFRONT8,J3) !$ RRMAX = RZERO !$OMP DO schedule(static, CHUNK) !$ DO J = 1, J3 !$ JJ = J1 + int(J-1,8)*NFRONT8 !$ VALABS = abs(A(JJ)) !$ IF (VALABS.GT.RRMAX) THEN !$ RRMAX = VALABS !$ JJMAX = J !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (RRMAX.GT.0.0) THEN !$OMP CRITICAL !$ IF (RRMAX.GT.RMAX) THEN !$ RMAX = RRMAX !$ JMAX = JJMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE JMAX = CMUMPS_IXAMAX(J3,A(J1),NFRONT) !$ ENDIF ELSE JMAX = CMUMPS_IXAMAX(J3,A(J1),NFRONT) ENDIF 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) 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) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(J1) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) IF (J3.GE.K360) DO J=1,J3 J1 = J1_ini + int(J-1,8) * NFRONT8 RMAX = max(abs(A(J1)),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)).GT.max(UU*RMAX,SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE.max(UU*RMAX,SEUIL,tiny(RMAX))) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DKEEP(6), & KEEP(259) ) ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 KEEP(260)=-KEEP(260) 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 KEEP(260)=-KEEP(260) 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 (KEEP(201).EQ.1) 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) !$ 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 NEL,IROW,NEL2,JCOL, NCB INTEGER NPIVP1 COMPLEX, PARAMETER :: ONE=(1.0E0,0.0E0) !$ LOGICAL:: OMP_FLAG !$ INTEGER:: NOMP, K360, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ K360 = KEEP(360) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NEL2 = NASS - NPIVP1 NCB = NFRONT - NASS - KEEP(253) IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) !$ OMP_FLAG = .FALSE. !$ CHUNK = NEL !$ 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) !$ ENDIF !$ ELSE !$ OMP_FLAG = .TRUE. !$ CHUNK = max(K360/2,NEL/NOMP) !$ 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) 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_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM & ) IMPLICIT NONE INTEGER(8) :: LA,POSELT COMPLEX A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL CALL_UTRSM INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1,NEL11 COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) CALL ctrsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_UTRSM) THEN UPOS = POSELT + int(NASS,8) CALL ctrsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) CALL cgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE CMUMPS_FAC_P SUBROUTINE CMUMPS_FAC_P_PANEL(A,LAFAC,NFRONT, & NPIV,NASS, IW, LIWFAC, & MonBloc, TYPEFile, MYID, KEEP8, & STRAT, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten) USE CMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NPIV, NASS INTEGER(8) :: LAFAC INTEGER LIWFAC, TYPEFile, MYID, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten, STRAT COMPLEX A(LAFAC) INTEGER IW(LIWFAC) INTEGER(8) KEEP8(150) TYPE(IO_BLOCK) :: MonBloc INTEGER(8) :: LPOS2,LPOS1,LPOS INTEGER NEL1,NEL11 COMPLEX ALPHA, ONE LOGICAL LAST_CALL PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = 1_8 + int(NASS,8) * int(NFRONT,8) CALL ctrsm('L','L','N','N',NPIV,NEL1,ONE,A(1),NFRONT, & A(LPOS2),NFRONT) LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) LPOS = LPOS2 + int(NPIV,8) LPOS1 = int(1 + NPIV,8) CALL cgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE CMUMPS_FAC_P_PANEL 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, & CALL_UTRSM, CALL_GEMM, WITH_COMM_THREAD ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD INTEGER(8) :: NFRONT8 INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER NELIM, LKJIW, NEL1, NEL11 COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) 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 IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + & int(IEND_BLOCK,8) POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*NFRONT8 + int(IBEG_BLOCK - 1,8) CALL ctrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) IF (CALL_UTRSM) THEN CALL ctrsm('R','U','N','U',NEL1,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),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 ENDIF RETURN END SUBROUTINE CMUMPS_FAC_SQ SUBROUTINE CMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB) 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) 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, LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG) USE CMUMPS_OOC IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW, & 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) TYPE(IO_BLOCK), intent(inout) :: MonBloc INTEGER :: NPIV, NEL1, STRAT, TYPEFile, IFLAG_OOC, & 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 (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_BOTH_LU MonBloc%LastPiv= NPIV CALL CMUMPS_FAC_P_PANEL(A(POSELT), LAFAC, NFRONT, & NPIV, NASS, IW(IOLDPS), LIWFAC, & MonBloc, TYPEFile, MYID, KEEP8, & STRAT, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC ELSE CALL CMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM & ) ENDIF 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,IOLDPS,POSELT,UU,SEUIL, & KEEP, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv & ) IF (INOPV.NE.1) THEN CALL CMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL) 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,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, & 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 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 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 REAL PIVNUL COMPLEX FIXA, CSEUIL INTEGER NPIV,IPIV INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF INTEGER CMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0E0/ !$ INTEGER :: J4,JJMAX,NOMP,CHUNK,K361 !$ REAL :: RRMAX,VALABS INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U !$ NOMP = OMP_GET_MAX_THREADS() !$ K361 = KEEP(361) 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 IF (KEEP(201).EQ.1) 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 IF(abs(A(APOS)).LT.SEUIL) THEN IF (real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF KEEP(98) = KEEP(98)+1 ELSE IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1) 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.GT.0.AND.UU.GT.RZERO) GO TO 340 IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 340 CONTINUE 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 IF (KEEP(351).EQ.1) THEN !$ IF (NOMP.GT.1 .AND. J.GE.K361) THEN !$ JMAX = 1 !$ RMAX = RZERO !$ CHUNK = max(K361/2,J/NOMP) !$OMP PARALLEL PRIVATE(J3,VALABS,JJMAX,RRMAX) !$OMP& FIRSTPRIVATE(J1,J) !$ RRMAX = RZERO !$OMP DO schedule(static, CHUNK) !$ DO J4 = 1, J !$ J3 = J1 + int(J4-1,8) !$ VALABS = abs(A(J3)) !$ IF(VALABS.GT.RRMAX) THEN !$ RRMAX = VALABS !$ JJMAX = J4 !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (RRMAX.GT.0.0) THEN !$OMP CRITICAL !$ IF (RRMAX.GT.RMAX) THEN !$ RMAX = RRMAX !$ JMAX = JJMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE JMAX = CMUMPS_IXAMAX(J,A(J1),1) !$ ENDIF ELSE JMAX = CMUMPS_IXAMAX(J,A(J1),1) ENDIF 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),8) ELSE J2 = APOS +int(- NPIV + NASS - 1 - KEEP(253),8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1) THEN !$ CHUNK = max(K361/2,int(J2-J1)/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 ENDIF 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF ( RMAX .LE. PIVNUL ) THEN 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(LAST_ROW-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LAST_ROW-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO KEEP(109) = KEEP(109)+1 ISW = IOLDPS+HF+ & IW(IOLDPS+1+XSIZE)+IPIV-NPIVP1 PIVNUL_LIST(KEEP(109)) = IW(ISW) 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 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 IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DKEEP(6), & KEEP(259)) ENDIF 385 CONTINUE IF (IPIV.EQ.NPIVP1) GO TO 400 KEEP(260)=-KEEP(260) 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 KEEP(260)=-KEEP(260) 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 (KEEP(201).EQ.1) 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, & NNEG, & 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,INODE,IFLAG,INOPV, & IOLDPS, NNEG INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv 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 include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM REAL RMAX,AMAX,TMAX REAL MAXPIV REAL PIVNUL COMPLEX FIXA, CSEUIL COMPLEX PIVOT,DETPIV INCLUDE 'mumps_headers.h' 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) LOGICAL OMP_FLAG INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L 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) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF KEEP(98) = KEEP(98)+1 ELSE IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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 IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) 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 (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. 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 + 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 IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSEIF (PIVOT_OPTION.EQ.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT: PIVOT_OPTION=', & PIVOT_OPTION ENDIF J1_ini = J1 IF ( (LIM - KEEP(253) - IEND_BLOCK).GE.300 ) THEN OMP_FLAG = .TRUE. ELSE OMP_FLAG = .FALSE. ENDIF !$OMP PARALLEL DO PRIVATE(J1) REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - KEEP(253) - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN KEEP(109) = KEEP(109)+1 PIVNUL_LIST(KEEP(109)) = -1 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,NFRONT - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) 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,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSEIF (PIVOT_OPTION.EQ.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT: PIVOT_OPTION=', & PIVOT_OPTION 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 (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 OMP_FLAG = (LIM-JMAX-KEEP(253). GE. 300) !$OMP PARALLEL DO IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX - KEEP(253) 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_FLAG = (LIM-JMAX-KEEP(253). GE. 300) !$OMP PARALLEL DO PRIVATE(JJ) REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX-KEEP(253) 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 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 IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(103) = KEEP(103)+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 CALL CMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDA, NFRONT, 1, KEEP(219), KEEP(50), & KEEP(IXSZ), -9999) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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, & KEEP253, PIVOT_OPTION, IEND_BLR & ) 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) :: PIVOT_OPTION, IEND_BLR INTEGER(8) :: POSELT REAL, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, INTENT(in) :: KEEP253 COMPLEX VALPIV REAL :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2, NEL, LIM 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 COMPLEX SWOP,DETPIV,MULT1,MULT2 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 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 MAXFROMM = 0.0E00 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 IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSE LIM = IEND_BLR ENDIF NCB1 = LIM - IEND_BLOCK 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 - KEEP253 > 300) DO I=NEL2+1, NEL2 + NCB1 - KEEP253 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 - KEEP253 + 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 ELSE IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSE LIM = IEND_BLR ENDIF 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(LIM-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL ccopy(LIM-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 DO J2 = IEND_BLOCK+1,LIM 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 JJ = JJ + NFRONT8 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_FAC_MQ_LDLT SUBROUTINE CMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,LAST_VAR,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & PIVOT_OPTION, CALL_TRSM) 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, intent(in) :: LAST_VAR INTEGER :: KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: PIVOT_OPTION LOGICAL, intent(in) :: CALL_TRSM INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1, I, II INTEGER(8) :: LPOS,UPOS,APOS INTEGER IROW INTEGER Block INTEGER BLSIZE, ELSIZE COMPLEX ONE, ALPHA, VALPIV INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) LDA8 = int(LDA,8) ELSIZE = IEND_BLOCK - IBEG_BLOCK +1 NEL1 = LAST_VAR - IEND_BLOCK NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (PIVOT_OPTION.LE.1.AND.CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) CALL ctrsm('L', 'U', 'T', 'U', ELSIZE, NEL1, ONE, & A(APOS), LDA, A(LPOS), LDA) !$OMP PARALLEL PRIVATE(VALPIV,I,II) DO I = 1, ELSIZE VALPIV = ONE/A(POSELT+(LDA8+1_8)*int(IBEG_BLOCK+I-2,8)) !$OMP DO DO II = 1,NEL1 A(UPOS+int(I-1,8)*LDA8 + int(II-1,8)) = & A(LPOS+int(I-1,8) + int(II-1,8)*LDA8) A(LPOS+int(I-1,8) + int(II-1,8)*LDA8) = & A(LPOS+int(I-1,8) + int(II-1,8)*LDA8)*VALPIV ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ENDIF IF ( LAST_VAR - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_VAR - IEND_BLOCK END IF IF ( NASS - IEND_BLOCK .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = IEND_BLOCK+1, LAST_VAR, BLSIZE Block = min( BLSIZE, NASS - 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_VAR, BLSIZE Block = min( BLSIZE, LAST_VAR - 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_VAR - IROW + 1, NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF LPOS = POSELT + int(LAST_VAR,8)*LDA8 + int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_VAR,8)*LDA8 + int(IEND_BLOCK,8) IF (PIVOT_OPTION.EQ.3) THEN CALL cgemm('N', 'N', NEL1, NFRONT-LAST_VAR, NPIV_BLOCK, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) ELSEIF (PIVOT_OPTION.EQ.2.AND.(NASS.GT. LAST_VAR)) THEN CALL cgemm('N', 'N', NEL1, NASS-LAST_VAR, NPIV_BLOCK, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_SQ_LDLT SUBROUTINE CMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, NASS, & LDA, NFRONT, LEVEL, K219, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, NASS, LEVEL, K219, K50, XSIZE COMPLEX A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: LASTROW2SWAP, 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 IF (LEVEL .EQ. 1) THEN LASTROW2SWAP = NFRONT ELSE LASTROW2SWAP = NASS ENDIF CALL cswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF (K219.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2) 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_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) 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 INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, I, J, IROWEND INTEGER I2, I2END, Block2 COMPLEX ONE, ALPHA, BETA, ZERO COMPLEX :: MULT1, MULT2, A11, DETPIV, A22, A12 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(57) ) THEN BLSIZE = KEEP(58) 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 CALL ctrsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NPIV, ONE, & A( POSELT ), LDA, & A( POSELT + LDA8 * int(NPIV,8) ), LDA ) 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 DPOS = POSELT I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN A11 = ONE/A(DPOS) CALL ccopy(Block, A(LPOS+int(I-1,8)), LDA, & A(UPOS+int(I-1,8)*LDA8), 1) CALL cscal(Block, A11, A(LPOS+int(I-1,8)), LDA) DPOS = DPOS + int(LDA+1,8) I = I+1 ELSE CALL ccopy(Block, A(LPOS+int(I-1,8)), LDA, & A(UPOS+int(I-1,8)*LDA8), 1) CALL ccopy(Block, A(LPOS+int(I,8)), LDA, & A(UPOS+int(I,8)*LDA8), 1) 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,Block 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 DPOS = POSPV2 + int(LDA+1,8) I = I+2 ENDIF ENDDO 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 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 END MODULE CMUMPS_FAC_FRONT_AUX_M MUMPS_5.1.2/src/zlr_core.F0000664000175000017500000007741113164366266015470 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE ZMUMPS_LR_CORE USE MUMPS_LR_COMMON USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,KSVD,M,N,ISLR) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,KSVD,M,N LOGICAL,INTENT(IN) :: ISLR C This routine simply initializes a LR block but does NOT allocate it LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%KSVD = KSVD LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) IF (ISLR) THEN LRB_OUT%LRFORM = 1 ELSE LRB_OUT%LRFORM = 0 ENDIF END SUBROUTINE INIT_LRB SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS, K486, K489, & K490, K491, K492, N, LRGROUPS, LRSTATUS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, K486, K489, K490, & K491, K492 INTEGER,INTENT(IN) :: N, LRGROUPS(N) INTEGER,INTENT(OUT):: LRSTATUS C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB COMPRESS_PANEL = .FALSE. IF ((K486.GT.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.EQ.1) COMPRESS_PANEL =.FALSE. IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF COMPRESS_CB = .FALSE. IF ((K492.GT.0).AND.(K489.EQ.1).AND.(NFRONT-NASS.GT.K491)) THEN COMPRESS_CB = .TRUE. ENDIF 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 END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,KSVD,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,KSVD,M,N INTEGER,INTENT(OUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok COMPLEX(kind=8) :: ZERO PARAMETER (ZERO=(0.0D0,0.0D0)) 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) write(*,*) 'Allocation problem in BLR routine ALLOC_LRB:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF ENDIF ELSE allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N write(*,*) 'Allocation problem in BLR routine ALLOC_LRB:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF nullify(LRB_OUT%R) ENDIF LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%KSVD = KSVD LRB_OUT%ISLR = ISLR IF (ISLR) THEN LRB_OUT%LRFORM = 1 ELSE LRB_OUT%LRFORM = 0 ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF KEEP8(70) = KEEP8(70) - int(MEM,8) KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - int(MEM,8) KEEP8(69) = min(KEEP8(71), KEEP8(69)) END SUBROUTINE ALLOC_LRB 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 LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2 ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1)) 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)) DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE ZMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, POSELTD, & 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_LRGEMM3) 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) :: POSELTD, POSELTT INTEGER, INTENT(IN) :: MAXI_CLUSTER COMPLEX(kind=8), intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS COMPLEX(kind=8) :: PIV1, PIV2, OFFDIAG IF (LRB%LRFORM.EQ.1) THEN NROWS = LRB%K ELSE ! Full Rank Block NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot 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: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_LRGEMM3(TRANSB1, TRANSB2, ALPHA, & LRB1, LRB2, BETA, A, LA, POSELTT, NFRONT, SYM, NIV, & IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, RANK, BUILDQ, & POSELTD, LD_DIAG, IW2, BLOCK, MAXI_CLUSTER) TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, NIV INTEGER,INTENT(OUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8), INTENT(IN), OPTIONAL :: POSELTD INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER CHARACTER(len=1),INTENT(IN) :: TRANSB1, TRANSB2 INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT DOUBLE PRECISION, intent(in) :: TOLEPS COMPLEX(kind=8) :: ALPHA,BETA COMPLEX(kind=8), intent(inout), OPTIONAL :: BLOCK(:) COMPLEX(kind=8), ALLOCATABLE, 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, TRANSX, TRANSY, TRANSZ INTEGER :: M_X, K_XY, K_YZ, N_Z, LDX, LDY, LDY1, LDY2, LDZ, K_Y INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK LOGICAL :: BUILDQ DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX(kind=8), ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: T1, T2, CR INTEGER :: allocok, MREQ DOUBLE PRECISION :: LOC_UPDT_TIME_OUT 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 (LRB2%M.EQ.0) THEN write(*,*) "Internal error in ZMUMPS_LRGEMM3, LRB2%M=0" CALL MUMPS_ABORT() ENDIF IF ((SYM.NE.0).AND.((TRANSB1.NE.'N').OR.(TRANSB2.NE.'T'))) THEN WRITE(*,*) "SYM > 0 and (", TRANSB1, ",", TRANSB2, & ") parameters found. Symmetric LRGEMM is only ", & "compatible with (N,T) parameters" CALL MUMPS_ABORT() ENDIF RANK = 0 BUILDQ = .FALSE. IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==1)) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) GOTO 700 allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 860 ENDIF IF (TRANSB1 == 'N') THEN X => LRB1%Q LDX = LRB1%M M_X = LRB1%M 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K ELSE !TRANSB1 == 'T' M_X = LRB1%N X => LRB1%R LDX = LRB1%K K_Y = LRB1%M Y1 => LRB1%Q LDY1 = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN Z => LRB2%R LDZ = LRB2%K N_Z = LRB2%N Y2 => LRB2%Q LDY2 = LRB2%M ELSE !TRANSB2 == 'T' N_Z = LRB2%M Z => LRB2%Q LDZ = LRB2%M Y2 => LRB2%R LDY2 = LRB2%K ENDIF TRANSZ = TRANSB2 CALL zgemm(TRANSB1 , TRANSB2 , LRB1%K , LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) BUILDQ = .FALSE. IF (COMPRESS_MID_PRODUCT.GE.1) THEN LWORK = MAX(LRB2%K**2, M_X**2) 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 860 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(1), TAU_RRQR(1), WORK_RRQR(1), & LRB2%K, RWORK_RRQR(1), TOLEPS, RANK, MAXRANK, INFO) IF ((RANK.GT.MAXRANK).OR.(RANK.EQ.0)) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN ! Successfully compressed middle block allocate(XQ(M_X,RANK), R_Y(RANK,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = M_X*RANK + RANK*LRB2%K GOTO 860 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 CALL zungqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL zgemm(TRANSB1, 'N', M_X, RANK, LRB1%K, ONE, & X(1,1), LDX, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), M_X) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ LDX = M_X K_XY = RANK TRANSX = 'N' deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSX = TRANSB1 TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE ! LRB1%K < LRB2%K SIDE = 'R' ENDIF ENDIF ENDIF IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN IF (LRB1%K.EQ.0) GOTO 700 SIDE = 'R' K_XY = LRB1%K TRANSX = TRANSB1 TRANSY = TRANSB1 Z => LRB2%Q LDZ = LRB2%M TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN X => LRB1%Q LDX = LRB1%M M_X = LRB1%M 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF ELSE ! TRANSB1 == 'T' X => LRB1%R LDX = LRB1%K M_X = LRB1%N Y => LRB1%Q LDY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN K_YZ = LRB2%M N_Z = LRB2%N ELSE ! TRANSB2 == 'T' K_YZ = LRB2%N N_Z = LRB2%M ENDIF ENDIF IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN IF (LRB2%K.EQ.0) GOTO 700 SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q LDX = LRB1%M TRANSX = TRANSB1 TRANSY = TRANSB2 TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN M_X = LRB1%M K_XY = LRB1%N ELSE ! TRANSB1 == 'T' M_X = LRB1%N K_XY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN Y => LRB2%Q LDY = LRB2%M Z => LRB2%R LDZ = LRB2%K N_Z = LRB2%N ELSE ! TRANSB2 == 'T' IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE ! Symmetric case: column scaling of R2 is done allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q LDZ = LRB2%M N_Z = LRB2%M ENDIF ENDIF IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' LDX = LRB1%M TRANSX = TRANSB1 Z => LRB2%Q LDZ = LRB2%M TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN M_X = LRB1%M K_XY = LRB1%N ELSE ! TRANSB1 == 'T' M_X = LRB1%N K_XY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN N_Z = LRB2%N ELSE ! TRANSB2 == 'T' N_Z = LRB2%M ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z allocate(XY_YZ(M_X,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = M_X*K_YZ GOTO 860 ENDIF CALL zgemm(TRANSX , TRANSY , M_X , K_YZ, K_XY, ONE, & X(1,1), LDX, Y(1,1), LDY, ZERO, XY_YZ(1,1), M_X) CALL SYSTEM_CLOCK(T1) CALL zgemm('N', TRANSZ, M_X, N_Z, K_YZ, ALPHA, & XY_YZ(1,1), M_X, Z(1,1), LDZ, BETA, A(POSELTT), & NFRONT) CALL SYSTEM_CLOCK(T2,CR) LOC_UPDT_TIME_OUT = dble(T2-T1)/dble(CR) CALL UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) deallocate(XY_YZ) ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ allocate(XY_YZ(K_XY,N_Z),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*N_Z GOTO 860 ENDIF CALL zgemm(TRANSY , TRANSZ , K_XY , N_Z, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LDZ, ZERO, XY_YZ(1,1), K_XY) CALL SYSTEM_CLOCK(T1) CALL zgemm(TRANSX, 'N', M_X, N_Z, K_XY, ALPHA, & X(1,1), LDX, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) CALL SYSTEM_CLOCK(T2,CR) LOC_UPDT_TIME_OUT = dble(T2-T1)/dble(CR) CALL UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) deallocate(XY_YZ) ELSE ! SIDE == 'N' : NONE; A = X*Z CALL zgemm(TRANSX, TRANSZ, M_X, N_Z, K_XY, ALPHA, & X(1,1), LDX, Z(1,1), LDZ, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 870 860 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine ZMUMPS_LRGEMM3: ', & 'not enough memory? memory requested = ' , MREQ IFLAG = - 13 IERROR = MREQ RETURN 870 CONTINUE C Alloc ok!! IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE ! 1 AND 1 IF ((TRANSB1=='N').AND.(SYM .NE. 0)) deallocate(Y1) IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 700 CONTINUE END SUBROUTINE ZMUMPS_LRGEMM3 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 END MODULE ZMUMPS_LR_CORE SUBROUTINE ZMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, 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 The authors of the LAPACK library are: C - Univ. of Tennessee C - Univ. of California Berkeley C - Univ. of Colorado Denver C - NAG Ltd. IMPLICIT NONE INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK DOUBLE PRECISION :: TOLEPS INTEGER :: JPVT(*) DOUBLE PRECISION :: RWORK(*) COMPLEX(kind=8) :: A(LDA,*), TAU(*) COMPLEX(kind=8) :: WORK(LDW,*) 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 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 CALL XERBLA( 'CGEQP3', -INFO ) RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RETURN END IF NB = ILAENV( INB, 'CGEQRF', ' ', M, N, -1, -1 ) 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 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 ) C IF(VN1(PVT).LT.TOLEPS) THEN IF(RWORK(PVT).LT.TOLEPS) 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 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 END DO RANK = RK END SUBROUTINE ZMUMPS_TRUNCATED_RRQR MUMPS_5.1.2/src/cfac_mem_stack.F0000664000175000017500000005172513164366264016566 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, & IPOOL, LPOOL, LEAF, NSTK_S, & NBPROCFILS, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, & OPASSW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(40), KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, 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 ), & 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 NBPROCFILS( KEEP(28) ) 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, & NBROW_STACK, NBCOL_STACK, NELIM 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 COMPRESSCB, MUST_COMPACT_FACTORS LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE 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)),SLAVEF) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),SLAVEF) LREQCB = 0_8 INPLACE = .FALSE. COMPRESSCB= ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1) 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(*,*) "COMPRESSCB, NFRONT, NPIV, NASS, NSLAVES", & COMPRESSCB, 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 KEEP8(10) = KEEP8(10) + int(NPIV,8) * int(NFRONT,8) ELSE KEEP8(10) = KEEP8(10) + ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF KEEP8(10) = KEEP8(10) + int(NBROW,8) * int(NPIV,8) 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 ) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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)),SLAVEF) 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, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), SLAVEF ) 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 ), COMPRESSCB, & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) .EQ. MYID ) THEN LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_SEND = 0 IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NBROW ELSE NBCOL_STACK = NBCOL ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBCOL_STACK = NBCOL LREQI = 6 + NBROW_STACK + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (COMPRESSCB) THEN LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 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, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .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 (COMPRESSCB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (COMPRESSCB) 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 ( 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 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, COMPRESSCB, & 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, COMPRESSCB ) 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 NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND 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 KEEP8(8)=KEEP8(8) + int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF 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) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE CMUMPS_FAC_STACK MUMPS_5.1.2/src/zfac_scalings_simScale_util.F0000664000175000017500000012052013164366266021322 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/dana_dist_m.F0000664000175000017500000007514413164366263016111 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, & NA, LNA, NE, DAD, ND, PROCNODE, SLAVEF, & NRLADU, NIRADU, NIRNEC, NRLNEC, & NRLNEC_ACTIVE, & NIRADU_OOC, NIRNEC_OOC, & MAXFR, OPSA, & KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND, SBUF_REC, 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 & ) IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER MYID, N, LNA, IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE 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), NA(LNA), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) 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, SBUF_REC 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, IPOOL, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR LOGICAL OUTER_SENDS_FR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER SBUFR, SBUFS INTEGER BLOCKING_RHS INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, NBROOT, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB, & LKJIBT, NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL COMPRESSCB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART 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 INTEGER MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_MAX_SURFCB_NBROWS, MUMPS_BLOC2_GET_NSLAVESMAX 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 COMPRESSCB=( 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), IPOOL(NSTEPS), & LSTKI(NSTEPS) , stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 4*NSTEPS RETURN endif LKJIB = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0) IF ( OUTER_SENDS_FR ) THEN LKJIB = max(LKJIB, KEEP(420)) ENDIF IF ( KEEP(486).NE.0 ) THEN LKJIB = max(LKJIB,KEEP(488)) ENDIF TNSTK = NE LEAF = NA(1)+1 IPOOL(1:LEAF-1) = NA(3:3+LEAF-2) NBROOT = NA(2) #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 = 0_8 ISTKI = 0 ISTKI_OOC = 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 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 NRLNEC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 ITOP = 0 MAXTEMPCB = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS = 1 SBUFR_CB = 1_8 SBUFR = 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 IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),SLAVEF) & .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 WRITE(MYID+6,*) ' ERROR 1 in DMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() 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)),SLAVEF) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),SLAVEF) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & SLAVEF) 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. COMPRESSCB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 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 & ) 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 NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & int(LOCAL_M,8)*int(LOCAL_N,8)) NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) 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)), SLAVEF)) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) 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 = max(SBUFS, NFR*LKJIB+LKJIB+4) ELSE SBUFS = max(SBUFS, NELIM*LKJIB+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR = max(SBUFR, NFR*LKJIB+LKJIB+4) else SBUFR = max( SBUFR, NELIM*LKJIB+NELIM+6 ) IF (KEEP(50).EQ.1) THEN LKJIBT = LKJIB ELSE LKJIBT = min( NELIM, LKJIB * 2 ) ENDIF SBUFS = max(SBUFS, & LKJIBT*NBROWMAX+6) SBUFR = max( SBUFR, NBROWMAX*LKJIBT+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 SIZECBI = 2* NCB + 6 + 3 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 MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECBI = NCB + 5 + 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) NRLADU = NRLADU + NRLADU_CURRENT ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) NRLADU = NRLADU + NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECBI = 4 + NBROWMAX + NCB 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 (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 (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 = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) ENDIF 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 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)),SLAVEF) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),SLAVEF) 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 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)), & SLAVEF) .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 NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF 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)),SLAVEF) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)),SLAVEF).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) ELSE NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) ENDIF 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) 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) 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. COMPRESSCB)) 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 * NFR + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.COMPRESSCB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN SIZECBI = 2+ XSIZE_IC ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) 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)) SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) SIZECBI = 0 SIZECB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE 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 SIZECBI = NCB + 5 + SLAVEF - 1 + XSIZE_IC SIZECB = 0_8 ELSE IF (UPDATE) THEN SIZECBI = NFR + 6 + SLAVEF - 1 + XSIZE_IC IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 SIZECBI = 0 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (COMPRESSCB) 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 = NCB + 5 + SLAVEF - 1 + XSIZE_IC ELSE SIZECB = SIZECB_SLAVE SIZECBI = 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) ) 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 BLOCKING_RHS = KEEP(84) IF (KEEP(84).EQ.0) BLOCKING_RHS=1 NRLNEC = max(NRLNEC, & NRLADU+int(4*KEEP(127)*abs(BLOCKING_RHS),8)) IF (BLOCKING_RHS .LT. 0) THEN BLOCKING_RHS = - 2 * BLOCKING_RHS ENDIF NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(4*KEEP(127)*BLOCKING_RHS,8)) SBUF_RECOLD = max(int(SBUFR,8),SBUFR_CB) SBUF_RECOLD = max(SBUF_RECOLD, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC = max(SBUFR, int(min(100000_8,SBUFR_CB))) SBUF_REC = SBUF_REC + 17 SBUF_REC = SBUF_REC + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND = max(SBUFS, int(min(100000_8,SBUFR_CB))) SBUF_SEND = SBUF_SEND + 17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC = SBUF_REC+KEEP(108)+1 SBUF_SEND = SBUF_SEND+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC = 1 SBUF_SEND= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, IPOOL, & LSTKI ) OPS_SUBTREE = dble(OPS_SBTR_LOC) OPSA = dble(OPSA_LOC) KEEP(66) = int(OPSA_LOC/1000000.d0) RETURN END SUBROUTINE DMUMPS_ANA_DISTM MUMPS_5.1.2/src/sfac_front_type2_aux.F0000664000175000017500000006561113164366263017771 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NNEG, & 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) 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, NNEG INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR INTEGER, intent(inout) :: Inextpiv 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 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 K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDAFS = NASS LDAFS8 = int(LDAFS,8) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) 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 IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEG = NNEG+1 ENDIF ELSE IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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 APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG (IPIV) = abs(A(POSPV1)) 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) NNEG = NNEG+1 IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) 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 = max(abs(A(J1)),AMAX) 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)),RMAX_NOSLAVE) J1 = J1 + LDAFS8 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 KEEP(109) = KEEP(109)+1 PIVNUL_LIST(KEEP(109)) = -1 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 + LDAFS8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO DO J=1,NASS - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDAFS8 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) NNEG = NNEG+1 IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) 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 J1 = POSPV1 + LDAFS8 DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(J1)),RMAX_NOSLAVE) ENDIF J1 = J1 + LDAFS8 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 IF (KEEP(258).NE.0) THEN CALL SMUMPS_UPDATEDETER(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(105) = KEEP(105)+1 IF(DETPIV .LT. RZERO) THEN NNEG = NNEG+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEG = NNEG+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 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(201).EQ.1.AND.KEEP(50).NE.1) 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) 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 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(NASS - NPIV_NEW,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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, SEND_LR, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_TYPE IMPLICIT NONE INCLUDE 'smumps_root.h' 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(40) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), & 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)), & NBPROCFILS(KEEP(28)), 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) :: SEND_LR 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 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 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, & SEND_LR, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/sfac_type3_symmetrize.F0000664000175000017500000001347313164366262020173 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/sfac_determinant.F0000664000175000017500000001354113164366262017145 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.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 MUMPS_5.1.2/src/mumps_version.F0000664000175000017500000000134113164366241016535 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2" ) 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.1.2/src/drank_revealing.F0000664000175000017500000000477713164366263017006 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), MPG KEEP(19)=0 RETURN END SUBROUTINE DMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE DMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL,KEEP,MPG,INFO) IMPLICIT NONE INTEGER KEEP(500), MPG, INFO(40), ICNTL(40) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 16 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 (ICNLT(9)=1) ' ENDIF ENDIF 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.1.2/src/dsol_root_parallel.F0000664000175000017500000000730713164366264017524 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), 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.1.2/src/cfac_front_LDLT_type2.F0000664000175000017500000006537513164366265017724 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NOFFW, & NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'cmumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 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(40), 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), & 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)), NBPROCFILS(KEEP(28)), & 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 INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTBL, LR_ACTIVATED 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 HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER PIVOT_OPTION EXTERNAL CMUMPS_BDC_ERROR LOGICAL STATICMODE REAL SEUIL_LOC REAL GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV COMPLEX ONE PARAMETER (ONE=(1.0E0,0.0E0)) NULLIFY(BLR_L) IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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 PIVOT_OPTION = MIN(2,KEEP(468)) IF (UUTEMP == 0.0E0 .AND. KEEP(201).NE.1) THEN 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 IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. NULLIFY(BEGS_BLR) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) 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 K263 = 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 IF (KEEP(201).EQ.1) THEN IDUMMY = -9876 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 CNT_NODES = CNT_NODES + 1 CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL SYSTEM_CLOCK(TTOT1FR) ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.2) PIVOT_OPTION=2 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 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 IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) 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,NOFFW,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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IF (IFLAG.LT.0) GOTO 490 IF(KEEP(109).GT. 0) THEN IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN IWPOSPIV = IOLDPS+IW(IOLDPS+1+XSIZE)+6 & +IW(IOLDPS+5+XSIZE) PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+XSIZE) ENDIF ENDIF IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN NPVW = NPVW + PIVSIZ IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. & ( (KEEP(485).EQ.0) .AND. (PIVOT_OPTION.GT.2) ) & ) & ) 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,IEND_BLR,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & PIVOT_OPTION, .FALSE.) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 2, 1) ENDIF IF (LR_ACTIVATED) THEN 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 GOTO 101 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V', 2) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 ENDIF 101 CONTINUE 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8,PIVOT_OPTION, .TRUE.) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) CALL MUMPS_ABORT() #if defined(BLR_MT) !$OMP PARALLEL #endif IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 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(8), KEEP(477) & ) IF (IFLAG.LT.0) GOTO 450 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 100 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (PIVOT_OPTION.LE.2) THEN CALL SYSTEM_CLOCK(T1) CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & NASS, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) ELSE IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & NASS, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) END IF ENDIF CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 (KEEP(201).EQ.1) 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 500 480 CONTINUE write(*,*) 'Allocation problem in BLR routine & CMUMPS_FAC_FRONT_LDLT_TYPE2: ', & 'not enough memory? memory requested = ' , IERROR 490 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, 1, INODE, & NELIM) CALL STATS_COMPUTE_FLOP_FRONT_TYPE2(NFRONT, NASS, KEEP(50), & INODE, NELIM) CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), & 2) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) 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.1.2/src/mumps_memory_mod.F0000664000175000017500000007600313164366241017226 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) INTEGER :: SIZE CALL MUMPS_SIZE_C(I (1), I (2), SIZE) ISIZE = int(SIZE,8) CALL MUMPS_SIZE_C(S (1), S (2), SIZE) SSIZE = int(SIZE,8) CALL MUMPS_SIZE_C(D (1), D (2), SIZE) DSIZE = int(SIZE,8) CALL MUMPS_SIZE_C(C (1), C (2), SIZE) CSIZE = int(SIZE,8) CALL MUMPS_SIZE_C(Z (1), Z (2), SIZE) ZSIZE = int(SIZE,8) CALL MUMPS_SIZE_C(I8(1), I8(2), SIZE) I8SIZE = int(SIZE,8) 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.1.2/src/sstatic_ptr_m.F0000664000175000017500000000172313164366263016512 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/cana_driver.F0000664000175000017500000050136213164366266016123 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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, FILS, FRERE, NFSIZ INTEGER NE, NA INTEGER I, allocok INTEGER MAXIS1_CHECK 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, SBUF_REC, 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 C to store the size of the sequencial peak of stack C (or an estimation for not calling REORDER_TREE_N ) REAL PEAK C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, DIMENSION(:) :: PAR2_NODES 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_STAT INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED 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 INTEGER, POINTER, DIMENSION(:) :: WORK1PTR, WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR ! Used because of multithreaded SIM_NP_ INTEGER :: locMYID, locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER(kind=8) :: N8, NZ8, LIW8 INTEGER :: LIW_ELT 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 KEEP8(24) = 0_8 ! reinitialize last used size of WK_USER KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) 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 ---------------------------------------- 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 (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) 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 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) C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ) 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 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ---------------------------------------------- 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 ( associated(id%MEM_DIST) ) deallocate( id%MEM_DIST ) 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 ) RETURN 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 ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( KEEP(54) .eq. 3 ) THEN C ----------------------------------------------- C Collect on the host -- if matrix is distributed C at analysis -- all integer information. C ----------------------------------------------- CALL CMUMPS_GATHER_MATRIX(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN END IF C ************************************************ C BEGINNING OF MASTER CODE FOR SEQUENTIAL ANALYSIS C ************************************************ 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. Done before 1234 label in order to avoid C two allocations of size 1 and a memory leak in case C there are two passes (see 1234 label below and C "GOTO 1234" statement) 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 in Schur ' CALL MUMPS_ABORT() END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF 1234 CONTINUE IF ( ( (KEEP(23) .NE. 0) .AND. & ( (KEEP(23).NE.7) .OR. KEEP(50).EQ. 2 ) ) & .OR. & ( associated(id%A) .AND. KEEP(52) .EQ. 77 .AND. & (KEEP(50).EQ.2)) & .OR. & KEEP(52) .EQ. -2 ) THEN C MAXIMUM TRANSVERSAL ALGORITHM called on original matrix. C KEEP(23) = 7 means that automatic choice C of max trans value will be done during Analysis. C We compute a permutation of the original matrix to have zero free diagonal C the col. Permutation is held in IS1(1, ...,N). C Max-trans (CMUMPS_ANA_O) is not used for element entry. IF (.not.associated(id%A)) THEN C -- If maxtrans is required and A not allocated then reset C -- it to structural based maxtrans. IF (KEEP(23).GT.2) KEEP(23) = 1 ENDIF CALL CMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%IS1(1), id, & ICNTL(1), INFO(1)) IF (INFO(1) .LT. 0) THEN C ----------- C Fatal error C ----------- C Permutation was not computed; reset keep(23) KEEP(23) = 0 GOTO 10 END IF END IF C END OF MAX-TRANS ON THE MASTER C C ********************************************************** C C BEGINNING OF ANALYSIS, STILL ON THE MASTER C C Set up subdivisions of arrays for analysis C C ------------------------------------------------------ C Define the size of a working array C that will be used as workspace CMUMPS_ANA_F. 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 N8=int(id%N,8) IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=int(id%KEEP8(28),8) IF ( KEEP(256) .EQ. 1 ) THEN ! KEEP(256) <-- ICNTL(7) LIW8 = 2_8 * NZ8 + N8 + 1_8 ELSE LIW8 = 2_8 * NZ8 + N8 + 1_8 ENDIF 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*N8) LIW8 = 3_8*N8 ELSE IF (LIW_ELT.LT.3*id%N) LIW_ELT = 3*id%N ENDIF IF (KEEP(23) .NE. 0) THEN IKEEP = id%N + 1 ELSE IKEEP = 1 END IF NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N MAXIS1_CHECK = NFSIZ + id%N - 1 C C ANALYSIS PHASE C Some workspace of CMUMPS_ANA_F can be reused in subsequent phases. C IS(IKEEP) OF LENGTH 3*N C IS(NFSIZ) OF LENGTH N holds the frontal matrix sizes C IS(FILS) and IS(FRERE) OF LENGTH N holds the assembly tree C IF ( KEEP(256) .EQ. 1 ) THEN C Note that id%PERM_IN has been checked before. DO I = 1, id%N id%IS1( IKEEP + I - 1 ) = id%PERM_IN( I ) END DO 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 CALL CMUMPS_ANA_F(id%N, id%KEEP8(28), & id%IRN(1), id%JCN(1), & LIW8, id%IS1(IKEEP), & KEEP(256), id%IS1(NFSIZ), & id%IS1(FILS), id%IS1(FRERE), & id%LISTVAR_SCHUR(1), SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1),id%NSLAVES, & id%IS1(1),id) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max trans KEEP(23) = -KEEP(23) IF (.NOT. associated(id%A)) KEEP(23) = 1 GOTO 1234 ENDIF INFOG(7) = KEEP(256) 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, & id%IS1(IKEEP), & KEEP(256), id%IS1(NFSIZ), id%IS1(FILS), & id%IS1(FRERE), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1)) 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 ) 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) C Check error during CMUMPS_ANA_F OR CMUMPS_ANA_F_ELT IF ( INFO(1) .LT. 0 ) THEN GO TO 10 ENDIF ENDIF ELSE C Parallel analysis IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N IF (id%MYID .EQ. MASTER) THEN C this correspond to the old PTRAR part of IS1 C WORK2PTR => id%IS1(PTRAR : PTRAR + 4*id%N-1) ALLOCATE(WORK2PTR(4*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(WORK1PTR(3*id%N),WORK2PTR(4*id%N), stat=IERR ) ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN INFO( 2 ) = 4*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 ) RETURN IF(id%MYID .EQ. MASTER) THEN WORK1PTR => id%IS1(IKEEP : IKEEP + 3*id%N-1) NFSIZPTR => id%IS1(NFSIZ : NFSIZ + id%N-1) FILSPTR => id%IS1(FILS : FILS + id%N-1) FREREPTR => id%IS1(FRERE : FRERE + id%N-1) END IF CALL CMUMPS_ANA_F_PAR(id, & WORK1PTR, & WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR) DEALLOCATE(WORK2PTR) IF(id%MYID .EQ. 0) THEN NULLIFY(WORK1PTR, NFSIZPTR) NULLIFY(FILSPTR, FREREPTR) ELSE DEALLOCATE(WORK1PTR) END IF KEEP(28) = INFOG(6) END IF 10 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN 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(id%N, id%IS1(FILS), id%IS1(FRERE), & id%IS1(NE), id%IS1(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 id%KEEP(20)=0 id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C id%PROCNODE = 0 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 CALL CMUMPS_SET_PROCNODE(id%KEEP(38), id%PROCNODE(1), & 1+2*id%NSLAVES, id%IS1(FILS),id%N) 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 => id%IS1(IKEEP:IKEEP+id%N-1) C Map nodes and assign candidates for dynamic scheduling CALL CMUMPS_DIST_AVOID_COPIES(id%N,id%NSLAVES,ICNTL(1), & INFOG(1), & id%IS1(NE), & id%IS1(NFSIZ), & id%IS1(FRERE), & id%IS1(FILS), & KEEP(1),KEEP8(1),id%PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & ) 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(id%N, id%IS1(FILS), & id%IS1(FRERE), id%IS1(NE), & id%IS1(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN 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) ) 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 ) RETURN 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, id%IS1(FRERE), & id%IS1(FILS), & id%IS1(IKEEP+id%N), id%IS1(IKEEP+2*id%N), 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 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 numbers. C This is used later in the initial elemental C matrix distribution at the beginning of the factorisation phase C --------------------------------------- CALL CMUMPS_ELTPROC(id%N, NELT, id%ELTPROC(1),id%NSLAVES, & id%PROCNODE(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, id%N IF ( ( id%IS1(FRERE+INODE-1) .NE. id%N+1 ) .AND. & ( MUMPS_TYPENODE(id%PROCNODE(INODE),id%NSLAVES) & .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 * =============================== * ! blocking factor for multiple RHS for ana_distm KEEP(84) = ICNTL(27) END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. 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 MUMPS_BCAST_I8( id%KEEP8(21), MASTER, & id%MYID, 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 ----------------- C Broadcast LR related keep informations KEEP(483-492) C if includes MPI_BCAST(idKEEP(486) CALL MPI_BCAST( id%KEEP(483), 10, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Save setting (used later during factorization) C to enable BLR KEEP(494) = KEEP(486) 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 C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) 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 CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 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 CALL MUMPS_REALLOC(id%LRGROUPS, id%N, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. IF ( associated( id%UNS_PERM ) ) deallocate(id%UNS_PERM) C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID == MASTER .AND. id%KEEP(23) .NE. 0 ) THEN C This one is only on the master allocate(id%UNS_PERM(id%N),stat=allocok) IF ( allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = id%N IF ( LPOK ) THEN WRITE(LP, 150) 'id%UNS_PERM' END IF GOTO 94 ENDIF C DO I=1,id%N id%UNS_PERM(I) = id%IS1(I) END DO ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN DO I=1,id%N id%FILS(I) = id%IS1(FILS+I-1) ENDDO END IF 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 (id%N.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (id%IS1(NA+id%N-1) .LT.0) THEN NBLEAF = id%N NBROOT = id%N ELSE IF (id%IS1(NA+id%N-2) .LT.0) THEN NBLEAF = id%N-1 NBROOT = id%IS1(NA+id%N-1) ELSE NBLEAF = id%IS1(NA+id%N-2) NBROOT = id%IS1(NA+id%N-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) IF(INFO(1).LT.0) GOTO 96 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 ( id%N == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (id%IS1(NA+id%N-1) < 0) THEN id%NA(LEAF) = - id%IS1(NA+id%N-1)-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO ELSE IF (id%IS1(NA+id%N-2) < 0 ) THEN INODE = - id%IS1(NA+id%N-2) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO END IF END IF 96 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF ( id%MYID .EQ. MASTER ) THEN 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, id%N IF ( id%IS1(FRERE+I-1) .ne. id%N + 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 = id%IS1(FILS+I-1) DO WHILE ( INN .GT. 0 ) id%STEP(INN) = - ISTEP INN = id%IS1(FILS + INN -1) END DO IF (id%IS1(FRERE+I-1) .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' CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ DO I = 1, id%N IF (id%IS1(FRERE+I-1) .NE. id%N+1) THEN id%PROCNODE_STEPS(id%STEP(I)) = id%PROCNODE( I ) id%FRERE_STEPS(id%STEP(I)) = id%IS1(FRERE+I-1) id%NE_STEPS(id%STEP(I)) = id%IS1(NE+I-1) id%ND_STEPS(id%STEP(I)) = id%IS1(NFSIZ+I-1) ENDIF ENDDO C =============================== C Algoritme 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, id%N C -- skip non principal nodes IF ( id%STEP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (id%IS1(FRERE+I-1) .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 = id%IS1(FILS+I-1) DO WHILE ( IFS .GT. 0 ) IFS= id%IS1(FILS + IFS -1) 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 = id%IS1(FRERE+IFS-1) ENDDO END DO C C C Following arrays (PROCNODE and IS1) not used anymore C during analysis DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) DEALLOCATE(id%IS1) NULLIFY(id%IS1) 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. 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%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 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 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%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 C Compute a grouping of variables for LR approximations. C id%SYM_PERM is used as a work array IF(KEEP(486) .EQ. 1) THEN IF ( (KEEP(54).eq.3) .AND. (KEEP(244).eq.2) ) THEN C If the input matrix is distributed and the parallel analysis is C chosen, the graph has to be centralized in order to compute the C clustering. CALL CMUMPS_GATHER_MATRIX(id) END IF IF (KEEP(469).EQ.0) THEN CALL CMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN(1), & id%JCN(1), id%FILS(1), id%FRERE_STEPS(1), & id%DAD_STEPS(1), id%NE_STEPS(1), id%STEP(1), id%NA(1), & id%LNA, id%LRGROUPS(1), & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), id%KEEP(489), & 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), LPOK, LP) ELSE CALL CMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN(1), & id%JCN(1), id%FILS(1), id%FRERE_STEPS(1), & id%DAD_STEPS(1), id%NE_STEPS(1), id%STEP(1), id%NA(1), & id%LNA, id%LRGROUPS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), id%KEEP(489), & 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), LPOK, LP) ENDIF IF ( (KEEP(54).eq.3) .AND. (KEEP(244).eq.2) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above deallocate(id%IRN, id%JCN) NULLIFY(id%IRN) NULLIFY(id%JCN) END IF END IF CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 80 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%INFO(1) ) ELSE ! matches the IF (id%MYID .EQ. MASTER) THEN ... above CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 80 IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2) & .AND. (abs(KEEP(486)).EQ.1)) THEN C If the input matrix is distributed and the parallel analysis is C chosen, the graph has to be centralized in order to compute the C clustering. CALL CMUMPS_GATHER_MATRIX(id) END IF ENDIF C Root principal variable C for scalapack (KEEP(38)) might have been updated C since root variables might have been permuted. C It should thus be redistributed to all procs IF((abs(KEEP(486)) .EQ. 1).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 ) RETURN 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(486).EQ.1) 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_PAR, 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_PAR(id, id%PTRAR(1)) 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 DEALLOCATE( id%IRN ) DEALLOCATE( id%JCN ) 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)) & deallocate(id%DEPTH_FIRST) 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)) * DEALLOCATE(id%DEPTH_FIRST_SEQ) 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)) * DEALLOCATE(id%SBTR_ID) 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)) & deallocate(id%DEPTH_FIRST) 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)) * DEALLOCATE(id%DEPTH_FIRST_SEQ) 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)) * DEALLOCATE(id%SBTR_ID) 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)) & deallocate(id%COST_TRAV) 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)) & deallocate(id%COST_TRAV) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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 ) RETURN 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)) deallocate(id%CANDIDATES) 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 ) RETURN 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 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 ! defined(OLD_LOAD_MECHANISM) 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%NSLAVES) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO #endif 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 ) RETURN C ------------------------------ C Perform again the subdivision of array C IS1, both on the master and on C the slaves. This is done so to C ease the passage to the model C where master will work. C ------------------------------ C IF ( KEEP(23).NE.0 .and. id%MYID .EQ. MASTER ) THEN IKEEP = id%N + 1 ELSE IKEEP = 1 END IF FILS = IKEEP + 3 * id%N NE = IKEEP + 2 * id%N NA = IKEEP + id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N 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 ) RETURN IF ( I_AM_SLAVE ) THEN 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 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 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 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)) ENDIF CALL CMUMPS_ANA_DISTM( locMYID_NODES, id%N, & id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), id%DAD_STEPS(1), & id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, & KEEP8(11), KEEP(26), KEEP(15), & KEEP8(12), ! formerly KEEP(16), & KEEP8(14), ! formerly KEEP(200), & KEEP(224), KEEP(225), & KEEP(27), RINFO(1), & KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, SBUF_RECOLD8, & SBUF_SEND, SBUF_REC, 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(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) + 2* 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) + 2* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) C size of S KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) C size of S KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /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 = max(SBUF_SEND,KEEP(27)) SBUF_REC = max(SBUF_REC ,KEEP(27)) CALL MPI_ALLREDUCE (SBUF_REC, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43)=KEEP(44) ELSE KEEP(43)=SBUF_SEND 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(43) = max(KEEP(43), 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 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 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0E0 END IF 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 -------------------------------------- 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) CALL MUMPS_REDUCEI8( KEEP8(11), KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) C -------------- C Flops estimate C -------------- CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_REAL, MPI_SUM, & id%COMM, IERR) 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) ) 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 IN-CORE MEMORY STATISTICS C ========================= OOC_STAT = KEEP(201) IF (KEEP(201) .NE. -1) OOC_STAT=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_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(2) = TOTAL_BYTES 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_STAT, PERLU_ON, TOTAL_BYTES) IF ( PROK ) THEN WRITE(MP,'(A,I10) ') & ' Estimated space in MBYTES for IC factorization :', & 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 WRITE( MPG,'(A,I16) ') & ' ** Rank of proc needing largest memory in IC facto :', & IRANK WRITE( MPG,'(A,I16) ') & ' ** Estimated corresponding MBYTES for IC facto :', & id%INFOG(16) IF ( KEEP(46) .eq. 0 ) THEN C Host not working WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,(id%INFOG(17)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,id%INFOG(17)/id%NSLAVES END IF WRITE(MPG,'(A,I16) ') & ' ** TOTAL space in MBYTES for IC factorization :' & ,id%INFOG(17) END IF C ========================================= C NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS C (except when OOC_STAT is equal to -1 in C which case IC and OOC statistics are C identical) C ========================================= OOC_STAT = KEEP(201) #if defined(OLD_OOC_NOPANEL) IF (OOC_STAT .NE. -1) OOC_STAT=2 #else IF (OOC_STAT .NE. -1) OOC_STAT=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_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(3) = TOTAL_BYTES 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_STAT, PERLU_ON, TOTAL_BYTES) id%INFO(17) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I16) ') & ' ** Rank of proc needing largest memory for OOC facto :', & IRANK WRITE( MPG,'(A,I16) ') & ' ** Estimated corresponding MBYTES for OOC facto :', & id%INFOG(26) IF ( KEEP(46) .eq. 0 ) THEN C Host not working WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,(id%INFOG(27)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,id%INFOG(27)/id%NSLAVES END IF WRITE(MPG,'(A,I16) ') & ' ** TOTAL space in MBYTES for OOC factorization :' & ,id%INFOG(27) END IF c #endif 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)) & deallocate( id%MAPPING) 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 CALL CMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & id%IRN(1),id%JCN(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 ) RETURN KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 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 Fwd in facto 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 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 IF ( PROKG ) THEN WRITE(MPG, '(A)') & ' Resetting candidate strategy to 0 because NSLAVES=1' WRITE(MPG, '(A)') ' ' END IF 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 IF ( PROKG ) THEN WRITE(MPG, '(A)') & ' Resetting candidate strategy to 8 ' WRITE(MPG, '(A)') ' ' END IF 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 ---------------------------- 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 kept for backward compatibility.' 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 * * Graph modification prior to ordering (id%ICNTL(12) option) * id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) * id%KEEP(95) = id%ICNTL(12) 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) = 0 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 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) = 7 C still forbid max trans for LLT IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not compatible with LLT 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 compatible with LLT 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).NE.0) 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 id%KEEP(95) = 1 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans 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)') & ' ** Max-trans not allowed because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN C Only Ruiz & Bora scaling available for dist format C (Work supported by ANR-SOLSTICE (ANR-06-CIS6-010)) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed (matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(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)') & ' ** Max-trans not allowed for element matrix' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling not allowed at analysis for element matrix' 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(39).NE.1 .and. id%ICNTL(39).NE.2) 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(39) 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(16) (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 -- Block low rank input parameter checking id%KEEP(486) = id%ICNTL(35) C KEEP(486)!=0,1 => KEEP(486)=0 IF (id%KEEP(486).NE.1) id%KEEP(486) = 0 IF(id%KEEP(486).NE.0) THEN C tests that may switch off BLR C C LR is incompatible with elemental matrices IF (id%KEEP(55).NE.0) THEN IF (PROK) WRITE(MP,*) & "WARNING: BLR feature currently incompatible " & ,"with elemental matrices" C Switch off BLR id%KEEP(486)=0 ENDIF C C LR incompatible with forward in facto in facto IF (id%KEEP(252).NE.0) THEN IF (PROK) WRITE(MP,*) & "WARNING: BLR feature currently incompatible " & ,"with forward during factorization" C Switch off BLR id%KEEP(486)=0 ENDIF IF((id%KEEP(492).EQ.0)) THEN id%KEEP(486)=0 ENDIF ENDIF C IF(id%KEEP(486).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(470)=0 or 1 IF ((id%KEEP(470).NE.0).AND.(id%KEEP(470).NE.1)) THEN id%KEEP(470)=1 ENDIF 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(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(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=4 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 IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 write(*,*) 'KEEP(480) = 0 => Resetting KEEP(474) to 0' ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 write(*,*) 'KEEP(480) < 4 => Resetting KEEP(478) to 0' ENDIF C In LUA strategy KEEP(480)>=5, we exploit LRTRSM to further C reduce the flops. It requires KEEP(475)>=2. 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 IF (id%KEEP(474).EQ.3) THEN write(*,*) 'KEEP(480) = ',id%KEEP(480), & ' and KEEP(474) = 3 ', & 'requires KEEP(475) >= 2, but it is = ', id%KEEP(475) ELSE write(*,*) 'KEEP(480) = ',id%KEEP(480), & 'requires KEEP(475) >= 2, but it is = ', id%KEEP(475) ENDIF 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 C id%KEEP(481)=0,1,2 IF ((id%KEEP(481).GT.2).OR.(id%KEEP(481).LT.0)) THEN id%KEEP(481)=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 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(485)>0 IF((id%KEEP(485).LT.0)) THEN id%KEEP(485)= 1 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(489)=0 or 1 IF ((id%KEEP(489).NE.0).AND.(id%KEEP(489).NE.1)) THEN id%KEEP(489)=0 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 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' TYPE(CMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: MASTER, IERR, INDX INTEGER :: STATUS(MPI_STATUS_SIZE) 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 PARAMETER( MASTER = 0 ) 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 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 GOTO 13 ENDIF 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)/20_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, opens a file and dumps the matrix and/or C the right hand side. This subroutine calls C CMUMPS_DUMP_MATRIX and CMUMPS_DUMP_RHS. C The routine should be called on all processors. C INCLUDE 'mpif.h' C Arguments C ========= TYPE(CMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED INTEGER :: MM_WRITE INTEGER :: MM_WRITE_CHECK CHARACTER(LEN=20) :: MM_IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER 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) 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 (id%WRITE_PROBLEM(1:20) .NE. "NAME_NOT_INITIALIZED")THEN 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 CLOSE(IUNIT) ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN C ===================== C Matrix is distributed C ===================== IF (id%WRITE_PROBLEM(1:20) .EQ. "NAME_NOT_INITIALIZED" & .OR. .NOT. I_AM_SLAVE )THEN MM_WRITE = 0 ELSE MM_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(MM_WRITE, MM_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 (MM_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(MM_IDSTR,'(I9)') id%MYID_NODES OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(MM_IDSTR))) CALL CMUMPS_DUMP_MATRIX(id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL ) ! Elemental or not CLOSE(IUNIT) ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. & id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED")THEN OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL CMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE CMUMPS_DUMP_PROBLEM SUBROUTINE CMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL ) 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 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)) 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)) 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)) 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)) 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" WRITE(IUNIT,*) id%A_ELT(:) 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, K, LD_RHS 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_RHS = id%N ELSE LD_RHS = id%LRHS ENDIF DO J = 1, id%NRHS DO I = 1, id%N K=(J-1)*LD_RHS+I WRITE(IUNIT,*) real(id%RHS(K)), aimag(id%RHS(K)) 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 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, K489, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & LPOK, LP) USE CMUMPS_ANA_LR C This routine is meant to compute a grouping of the variables in C all the separators. This grouping defines the blocks that will C be compressed by means of low-rank approximations. Because the C principal variables of all separators will be changed, it is C necessary to update the arrays FILS, FRERE_STEPS, DAD_STEPS, STEP, C NA. C C N - the size of the input matrix C NZ8 - the nnz in the input matrix C NSTEPS - the numbers of nodes in the tree C IRN - the row indices of the input matrix C JCN - the col indices of the input matrix C FILS - the fils array of size N. This array will be C modified on output according to the new relative C order computed for the variables in the separators C FRERE_STEPS - the FRERE_STEPS array. Modified on output (as for FILS) C DAD_STEPS - the DAD_STEPS array. Modified on output (as for FILS) C NE_STEPS - the NE_STEPS array. Modified on output (as for FILS) C STEP - the STEP array. Modified on output (as for FILS) C NA - the NA array. Modified on output (as for FILS) C LNA - The length of the NA array C LRGROUPS - the array mapping variables onto groups. C LRGROUPS(i)=k means that variable i belongs to C group k C SYM - the type of matrix (KEEP(50)) C ICNTL - the ICNTL array C HALO_DEPTH - the depth of the halo around the separator subgraph C GROUP_SIZE - the size of variables groups in the separators C K489 - BLR strategy (=3 compress CB) C SEP_SIZE - the minimum size of a separator to be treated with C low-rank approximations C has to be used for computing the clustering C IFLAG - < 0 in case of error C IERROR - complementary information in case of error C e- =0 upon succesful return, > 0 otherwise C C LP, LPOK to control error printing C C C This routine traverses the tree in a DFS fashion using a pool C where nodes are pushed as soon as their parent is treated. Nodes C are pushed in the pool in the same order as FRERE_STEPS and, since C nodes are popped from the head of this pool, this means that C siblings are treated in reverse order. This makes it easier to C modify FRERE_STEPS because it will be always updated wrt a node C which has already been treated. The update of NA relies on the C assumption that a DFS touches the leaves in the same order as they C appear in NA (in reverse order in this case for what said above). C The roots are therefore pushed in the pool in reverse order. C An array of order NSTEPS is allocated to store the principal C variables of all the nodes that have been treated. This array C could be spared at the price of expensive pointer chasing inside C FILS. IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE, K489 INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: IRN(NZ8), JCN(NZ8), NE_STEPS(NSTEPS), & ICNTL(40) INTEGER, INTENT(INOUT) :: FILS(N), FRERE_STEPS(NSTEPS), STEP(N), & NA(LNA), DAD_STEPS(NSTEPS), LRGROUPS(N) 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 INTERFACE 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) INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) END SUBROUTINE END INTERFACE C Check for Schur (// or sequential) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF C If automatic choice of partitioning tool is required, then metis C comes first, if available; otherwise scotch; otherwise C permuted matrix is simply split. C If a particular tool C is required, we check for its availability, otherwise we revert to C automatic choice 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 C The global number of groups computed NBGROUPS = 0 C Build the unsymmetrized graph of the input matrix. The LGROUPS C array will be immediately allocated and used as a scratchpad C memory for CMUMPS_ANA_GNEW IF (K265.EQ.-1) THEN C unsymmetric matrix, structurally symmetric LW = NZ8 ELSE C worst case need to double matrix size 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, IWFR, NRORM, NIORM, IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265) IF (allocated(IQ)) DEALLOCATE(IQ) C LRGROUPS has been used as a workspace in ana_gnew so we should C reinitialize it to -1 to be sure that a variable which is in no C group (ie in no grouped separator) can be identified correctly LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS C Push the roots in the pool in reverse order C DO I = 1, NROOTS C POOL(I) = NA(2+NLEAVES+NROOTS-I+1) C END DO C BUGFIX 18/11/2016 C Because the elements from the pool are taken in reverse order and the C NA is also updated in reverse order in MUMPS_UPD_TREE, this was C actually false! The roots should be pushed in the pool in natural C order. Cf email "Bugs L0" 18/11/2016. DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS C arrays of size N used to computed each halo 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 C Loop until the pool is empty DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) C This variable tells whether node is the oldest son of its parent. C In this case fils(fils(...fils(dad_steps(node)))) is updated FIRST = POOL(PP) .LT. 0 C Go down until the last variable in this front and make a list of C the fully assembled variables in it inside the work array NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO C Do the grouping. Upon return, work contains the variable in the C new order and NBGROUPS has been increased by the number of groups C computed in the current separator C Grouping is done if the current node is large enough, i.e. bigger C than the cluster size GROUP_SIZE. The grouping must be done C even if NV is smaller than SEP_SIZE: in that case, we give to all C of its variables a negative group number so that we have grouping C for all the variables which is needed in case we have for example C a chain like (say we do low-rank if nass > 8) father (nass=5) son (nass=10) C in this case we need a clustering of the CB of 'son' which may be partly C inherited from the clustering of the FS of 'father' so this latter C clustering should be done even if 'father' is not eligible for LR. Not C likely to happen often with metis-like ordering but it should be done C for robustness. C Moreover, as a front can be chosen for LR during facto even if the C separator was too small for proper grouping ( this occurs with delayed C pivots), we need the negative sign to avoid trying to do a LR facto in C such a case. 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 C Disable permutation/clustering. Leaves the ordering unchanged C and simply pack variables into groups of size SIZE_GROUP. C NB: this doesn't care about FS/CB, or about slaves, etc, so C it is useful only for a NIV1 root basically. DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+I/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + NV/GROUP_SIZE2 + 1 ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS(1), 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 C If NV is smaller than GROUP_SIZE then all variables are in a C single group, which value is negative if NV is also smaller C than SEP_SIZE. 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 C be careful, both val and -val are not present in the LRGROUPS array ENDIF C Update the tree according to the newly computed order CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS(1), FRERE_STEPS(1), STEP(1), DAD_STEPS(1), & NE_STEPS(1), NA(1), LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN C Restore potentially modified root number IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF C Put all the children of node in the pool. The first child is C always pushed with a negative index in order to establish when to C update the FILS array for the last variable in its parent (through C the FIRST variable above) 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) C RETURN END SUBROUTINE CMUMPS_LR_GROUPING SUBROUTINE CMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, K489, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, LPOK, LP) USE CMUMPS_ANA_LR C This routine is meant to compute a grouping of the variables in C all the separators. This grouping defines the blocks that will C be compressed by means of low-rank approximations. Because the C principal variables of all separators will be changed, it is C necessary to update the arrays FILS, FRERE_STEPS, DAD_STEPS, STEP, C NA. C C N - the size of the input matrix C NZ8 - the nnz in the input matrix C NSTEPS - the numbers of nodes in the tree C IRN - the row indices of the input matrix C JCN - the col indices of the input matrix C FILS - the fils array of size N. This array will be C modified on output according to the new relative C order computed for the variables in the separators C FRERE_STEPS - the FRERE_STEPS array. Modified on output (as for FILS) C DAD_STEPS - the DAD_STEPS array. Modified on output (as for FILS) C NE_STEPS - the NE_STEPS array. Modified on output (as for FILS) C STEP - the STEP array. Modified on output (as for FILS) C NA - the NA array. Modified on output (as for FILS) C LNA - The length of the NA array C LRGROUPS - the array mapping variables onto groups. C LRGROUPS(i)=k means that variable i belongs to C group k C SYM - the type of matrix (KEEP(50)) C ICNTL - the ICNTL array C HALO_DEPTH - the depth of the halo around the separator subgraph C GROUP_SIZE - the size of variables groups in the separators C SEP_SIZE - the minimum size of a separator to be treated with C low-rank approximations C has to be used for computing the clustering C IFLAG - < 0 in case of error C IERROR - complementary information in case of error C e- =0 upon succesful return, > 0 otherwise C C LP, LPOK to control error printing C C C This routine traverses the tree in a DFS fashion using a pool C where nodes are pushed as soon as their parent is treated. Nodes C are pushed in the pool in the same order as FRERE_STEPS and, since C nodes are popped from the head of this pool, this means that C siblings are treated in reverse order. This makes it easier to C modify FRERE_STEPS because it will be always updated wrt a node C which has already been treated. The update of NA relies on the C assumption that a DFS touches the leaves in the same order as they C appear in NA (in reverse order in this case for what said above). C The roots are therefore pushed in the pool in reverse order. C An array of order NSTEPS is allocated to store the principal C variables of all the nodes that have been treated. This array C could be spared at the price of expensive pointer chasing inside C FILS. IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE, K489 INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: IRN(NZ8), JCN(NZ8), NE_STEPS(NSTEPS), & ICNTL(40) INTEGER, INTENT(INOUT) :: FILS(N), FRERE_STEPS(NSTEPS), STEP(N), & NA(LNA), DAD_STEPS(NSTEPS), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, TARGET, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, POINTER, DIMENSION (:) :: TRACE_PTR, WORKH_PTR, & GEN2HALO_PTR INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR INTERFACE 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) INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) END SUBROUTINE END INTERFACE C Check for Schur (// or sequential) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF C If automatic choice of partitioning tool is required, then metis C comes first, if available; otherwise scotch; otherwise C permuted matrix is simply split. C If a particular tool C is required, we check for its availability, otherwise we revert to C automatic choice 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 C The global number of groups computed NBGROUPS = 0 C Build the unsymmetrized graph of the input matrix. The LGROUPS C array will be immediately allocated and used as a scratchpad C memory for CMUMPS_ANA_GNEW 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, IWFR, NRORM, NIORM, IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265) IF (allocated(IQ)) DEALLOCATE(IQ) C LRGROUPS has been used as a workspace in ana_gnew so we should C reinitialize it to -1 to be sure that a variable which is in no C group (ie in no grouped separator) can be identified correctly LRGROUPS = -1 IF (K469.NE.2) THEN C K469=1 or 3: arrays of size N shared by all threads 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 !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, !$OMP& WORKH_PTR, TRACE_PTR, GEN2HALO_PTR) IF(K469.GT.1) ALLOCATE(WORK(MAXFRONT), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT IFLAG = -7 IERROR = MAXFRONT GOTO 500 ENDIF IF (K469.EQ.2) THEN C K469=2: arrays of size N allocated on each thread ALLOCATE(TRACE_PTR(N), WORKH_PTR(N), GEN2HALO_PTR(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 500 ENDIF ELSE TRACE_PTR => TRACE WORKH_PTR => WORKH GEN2HALO_PTR => GEN2HALO ENDIF IF (K469.EQ.2) THEN TRACE_PTR = 0 ELSE !$OMP SINGLE TRACE_PTR = 0 !$OMP END SINGLE ENDIF C I) Parcours parallele en N pour initialiser PVS PVSCHANGED = .FALSE. !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO C II) Parcours parallele en NSTEPS pour faire le grouping avec C PVS, STEP et FILS (sauf derniere variable) qui sont mis a jour !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) C Construire VLIST a partir de FILS(PV) C Go down until the last variable in this front and make a list of C the fully assembled variables in it inside the work array NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO C Appel a SEP_GROUPING sur VLIST: la variable principale de NODE C change et devient PVS(NODE) C Do the grouping. Upon return, work contains the variable in the C new order and NBGROUPS has been increased by the number of groups C computed in the current separator C Grouping is done if the current node is large enough, i.e. bigger C than the cluster size GROUP_SIZE. The grouping must be done C even if NV is smaller than SEP_SIZE: in that case, we give to all C of its variables a negative group number so that we have grouping C for all the variables which is needed in case we have for example C a chain like (say we do low-rank if nass > 8) father (nass=5) son (nass=10) C in this case we need a clustering of the CB of 'son' which may be partly C inherited from the clustering of the FS of 'father' so this latter C clustering should be done even if 'father' is not eligible for LR. Not C likely to happen often with metis-like ordering but it should be done C for robustness. C Moreover, as a front can be chosen for LR during facto even if the C separator was too small for proper grouping ( this occurs with delayed C pivots), we need the negative sign to avoid trying to do a LR facto in C such a case. 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 C C Disable permutation/clustering. Leaves the ordering unchanged C and simply pack variables into groups of size SIZE_GROUP. C NB: this doesn't care about FS/CB, or about slaves, etc, so C it is useful only for a NIV1 root basically. !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+I/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + NV/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS(1), NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PTR, WORKH_PTR, & NODE, GEN2HALO_PTR, K482_LOC, K472, K469, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) CYCLE C Maj de PVS PVS(NODE) = WORK(1) PVSCHANGED = .TRUE. C Maj de STEP 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 C Maj de FILS DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN C La derniere variable de FILS memorise l'ancienne C variable principale pointee FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE C If NV is smaller than GROUP_SIZE then all variables are in a C single group, which value is negative if NV is also smaller C than SEP_SIZE. !$OMP CRITICAL(lrgrouping_cri) 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 !$OMP END CRITICAL(lrgrouping_cri) ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 C <<<< Synchro >>>> C A ce stade tous les noeuds ont ete traites et PVS, STEP et FILS (sauf derniere variable) C sont a jour C On economise les maj suivantes si inutiles IF (.NOT.PVSCHANGED) GOTO 500 C III) Maj de DAD_STEPS, FRERE_STEPS, NA, et derniere variable de chaque noeud de FILS !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN C Node has a younger brother, update frere_steps(node) FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN C node is the youngest brother, update frere_steps(node) to make C it point to the father 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.EQ.2) THEN DEALLOCATE(TRACE_PTR) DEALLOCATE(WORKH_PTR) DEALLOCATE(GEN2HALO_PTR) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469.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) C RETURN END SUBROUTINE CMUMPS_LR_GROUPING_NEW C SUBROUTINE SEP_GROUPING(NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, C & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH) C IMPLICIT NONE C INTEGER :: NV, N, NZ, LW, NBGROUPS, GROUP_SIZE, HALO_DEPTH C INTEGER :: VLIST(NV), LRGROUPS(N), IW(LW), IPE(N+1), LEN(N) C C INTEGER :: TMP, I C CC Just invert the list C DO I=1, NV/2 C TMP = VLIST(I) C VLIST(I) = VLIST(NV-I+1) C VLIST(NV-I+1) = TMP C END DO C C RETURN C END SUBROUTINE SEP_GROUPING MUMPS_5.1.2/src/cfac_front_LU_type2.F0000664000175000017500000006063013164366265017472 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'cmumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 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(40), 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), & 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)), NBPROCFILS(KEEP(28)), & 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 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 INTEGER PIVOT_OPTION, LAST_COL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER :: NOMP INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF NOMP=1 !$ NOMP=OMP_GET_MAX_THREADS() 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) IF (UUTEMP == 0.0E0 .AND. KEEP(201).NE.1) THEN ENDIF 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= .FALSE. NULLIFY(BEGS_BLR) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) 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 K263 = 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 IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 CNT_NODES = CNT_NODES + 1 CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL SYSTEM_CLOCK(TTOT1FR) ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 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 IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL CMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW, & 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, & IPIV & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. & (KEEP(485).EQ.0) & ) & ) 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 CALL CMUMPS_BUF_TEST() NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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, .FALSE., .TRUE., & .FALSE. ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF CALL CMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 2, 0) ENDIF IF (LR_ACTIVATED) THEN NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 101 ENDIF END_I=NB_BLR ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP(470), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H', 2) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (K263.NE.0) 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR .LT. NASS) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, (PIVOT_OPTION.LT.2), .TRUE. & , (KEEP(377) .EQ. 1) & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF CALL SYSTEM_CLOCK(T1) IF (IEND_BLR.LT.NFRONT) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, .FALSE., .FALSE., & .FALSE. ) ENDIF CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_TRSM_TIME = LOC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR)) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & 0, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), BEGS_BLR(CURRENT_BLR+1), & NPARTSASS, BLR_L, CURRENT_BLR, 'V', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & NFRONT, KEEP(470), & END_I_IN=END_I & ) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) CALL DEALLOC_BLR_PANEL (BLR_L, NPARTSASS-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF (KEEP(201).EQ.1) 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 CALL STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, 0, INODE, & NELIM) CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_FLOP_FRONT_TYPE2(NFRONT, NASS, KEEP(50), & STEP_STATS(INODE), NELIM ) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 480 CONTINUE write(*,*) 'Allocation problem in BLR routine & CMUMPS_FAC_FRONT_LU_TYPE2: ', & 'not enough memory? memory requested = ' , IERROR 490 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE DEALLOCATE( IPIV ) RETURN END SUBROUTINE CMUMPS_FAC2_LU END MODULE CMUMPS_FAC2_LU_M MUMPS_5.1.2/src/zmumps_iXamax.F0000664000175000017500000000215313164366265016501 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C INTEGER FUNCTION ZMUMPS_IXAMAX(N,X,INCX) COMPLEX(kind=8) X(*) DOUBLE PRECISION ABSMAX INTEGER :: I INTEGER(8) :: IX INTEGER INCX,N ZMUMPS_IXAMAX = 0 IF ( N.LT.1 ) RETURN ZMUMPS_IXAMAX = 1 IF ( N.EQ.1 .OR. INCX.LE.0 ) RETURN 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 RETURN END FUNCTION ZMUMPS_IXAMAX MUMPS_5.1.2/src/dfac_driver.F0000664000175000017500000037067713164366266016133 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_CORE USE DMUMPS_LR_STATS USE DMUMPS_LR_DATA_M, only: DMUMPS_BLR_INIT_MODULE, & DMUMPS_BLR_END_MODULE 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 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 C Explicit interface needed because C of "id" derived datatype argument 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 C 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(8) ::KEEP826_SAVE INTEGER(8) K67 INTEGER(8) K68,K69 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF INTEGER DMUMPS_LBUF, DMUMPS_LBUFR_BYTES, DMUMPS_LBUF_INT INTEGER(8) DMUMPS_LBUFR_BYTES8, DMUMPS_LBUF8 INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, NSTEPS, K28, LPOOL, LIW 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 INTEGER MIN_PERLU, MAXIS_ESTIM INTEGER MAXIS INTEGER(8) :: MAXS 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 INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER LIWK, LWK_REAL INTEGER(8) :: LWK C SLAVE: used to determine if proc has the role of a slave LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED C WK_USER_PROVIDED is set to true when workspace WK_USER is provided by user DOUBLE PRECISION :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2 DOUBLE PRECISION :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER FRONTWISE C temporary variable for collecting stats from all processors DOUBLE PRECISION :: TMP_GLOBAL_BLR_SAVINGS DOUBLE PRECISION :: TMP_ACC_FR_MRY DOUBLE PRECISION :: TMP_ACC_LR_FLOP_GAIN DOUBLE PRECISION :: TMP_ACC_FLOP_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_PANEL DOUBLE PRECISION :: TMP_ACC_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_ACC_FLOP_LR_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_FR_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_LR_UPDT DOUBLE PRECISION :: TMP_ACC_FLOP_LR_UPDT_OUT DOUBLE PRECISION :: TMP_ACC_FLOP_RMB DOUBLE PRECISION :: TMP_ACC_FLOP_DEC_ACC DOUBLE PRECISION :: TMP_ACC_FLOP_REC_ACC DOUBLE PRECISION :: TMP_ACC_FLOP_FR_UPDT DOUBLE PRECISION :: TMP_ACC_FLOP_DEMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_CB_DEMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_CB_PROMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_FR_FACTO INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_ACC_UPDT_TIME DOUBLE PRECISION :: TMP_ACC_DEMOTING_TIME DOUBLE PRECISION :: TMP_ACC_CB_DEMOTING_TIME DOUBLE PRECISION :: TMP_ACC_PROMOTING_TIME DOUBLE PRECISION :: TMP_ACC_FRPANELS_TIME DOUBLE PRECISION :: TMP_ACC_FAC_I_TIME DOUBLE PRECISION :: TMP_ACC_FAC_MQ_TIME DOUBLE PRECISION :: TMP_ACC_FAC_SQ_TIME DOUBLE PRECISION :: TMP_ACC_TRSM_TIME DOUBLE PRECISION :: TMP_ACC_FRFRONTS_TIME DOUBLE PRECISION :: TMP_ACC_LR_MODULE_TIME 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 C C External references C =================== INTEGER numroc EXTERNAL numroc C Fwd in facto: DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_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 C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS 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 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 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 ) IF ( PROKG .and. KEEP(53).GT.0 ) THEN WRITE(MPG,'(/A,I3)') ' Null space option :', KEEP(19) IF ( KEEP(21) .ne. N ) THEN WRITE( MPG, '(A,I10)') ' Max deficiency : ', KEEP(21) END IF IF ( KEEP(22) .ne. 0 ) THEN WRITE( MPG, '(A,I10)') ' Min deficiency : ', KEEP(22) END IF END IF 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 !Later: .GT. to allow ICNTL(22)=-1 # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(480).NE.0) THEN id%KEEP(480) = 0 IF (PROK) & write(MP,'(A)') & ' MUMPS is not compiled with -DBLR_LUA ', & ' => Resetting KEEP(480) to 0' ENDIF IF (id%KEEP(475).NE.0) THEN id%KEEP(475) = 0 IF (PROK) & write(MP,'(A)') & ' MUMPS is not compiled with -DLRTRSM ', & ' => Resetting KEEP(475) to 0' 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 ) IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & " Internal ERROR with BLR setting " WRITE(MPG,'(A)') " BLR was not activated during ", & " analysis and is requested during factorization. " id%INFO(1)=-900 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(470), 23, MPI_INTEGER, & MASTER, id%COMM, IERR ) 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 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 C 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 C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL(1) = 0.0 C --------------------------------------- IF ( KEEP(50) .eq. 1 ) THEN IF (id%CNTL(1) .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') &' ** Warning : SPD solver called, resetting CNTL(1) to 0.0D0' END IF END IF id%CNTL(1) = ZERO END IF 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 (PROKG) WRITE(MPG,'(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 (PROKG) WRITE(MPG,'(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 (PROKG) WRITE(MPG,'(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 IF ( PROKG ) THEN WRITE( MPG, 172 ) id%NSLAVES, id%ICNTL(22), & id%KEEP8(111), KEEP(126), KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, id%CNTL(1) IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) 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 530 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL)) 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 530 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) 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 530 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,*) 'ERREUR 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)) RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 530 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 -Rank revealing on the Schur (ICNTL(16)/KEEP(19)) C CNTL(6) is used to set SEUIL and SEUIL_LDLT_NIV2 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. C Note that SEUIL* might be reset later in this routine C but only when static pivoting is on C which will be excluded if null pivots or C rank-revealing (RR) is on C ----------------------------------------------- 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) CNTL1 = id%CNTL(1) CALL MPI_BCAST(CNTL1, 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) 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 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).EQ.0) THEN C -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO ELSE C -- RR is on C July 2012 C CNTL(3) is the threshold used in the following C to compute the SEUIL used for postponing pivots to root C SEUIL*CNTL(6) is then the treshold for null pivot detection C (with 0< CNTL(6) <= 1) IF (CNTL3 .LT. ZERO) THEN SEUIL = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN SEUIL = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN SEUIL = N*EPS*ANORMINF ! standard articles ENDIF IF (PROKG) WRITE(MPG,*) & ' ABSOLUTE PIVOT THRESHOLD for rank revealing =',SEUIL ENDIF C After QR with pivoting of root or SVD, diagonal entries C need be analysed to determine null space vectors. C Two strategies are provided : id%DKEEP(9) = SEUIL IF (id%DKEEP(10).LT.MONE) THEN id%DKEEP(10)=MONE ELSEIF((id%DKEEP(10).LE.ONE).AND.(id%DKEEP(10).GE.ZERO)) THEN id%DKEEP(10)=1000.0D0 ENDIF SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN 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 IF (ANORMINF.EQ.ZERO) & CALL DMUMPS_ANORMINF( id , ANORMINF, LSCAL ) IF (KEEP(19).NE.0) THEN C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed. C Pivot rows smaller than DKEEP(1) are directly added to null space C and thus considered as null pivot rows. Thus we define id%DKEEP(1) C relatively to SEUIL (which is based on CNTL(3)) IF (CNTL(6).GT.0.AND.CNTL(6).LT.1) THEN C we want DKEEP(1) < SEUIL id%DKEEP(1) = SEUIL*CNTL(6) ELSE id%DKEEP(1) = SEUIL* 0.01D0 ENDIF ELSE 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 id%DKEEP(1) = 1.0D-5*EPS*ANORMINF ENDIF ENDIF IF (PROKG) WRITE(MPG,*) & ' ZERO PIVOT DETECTION ON, THRESHOLD =',id%DKEEP(1) IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,*) & ' 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 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%NSLAVES) 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 C and in case of rank revealing 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 530 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 C -- Set KEEP(97) and compute static pivoting threshold. 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 ) C WRITE(*,*) id%MYID,': ANORMINF',ANORMINF ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE C WRITE(*,*) 'id%CNTL(4)',id%CNTL(4) 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 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 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C Allocate S on all nodes C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN C In-core MAXS_BASE8=id%KEEP8(12) ELSE C OOC or no factors stored MAXS_BASE8=id%KEEP8(14) ENDIF IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ELSE IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) C If PERLU < 0, we may obtain a C null or negative value of MAXS. IF (MAXS_BASE_RELAXED8 > huge(MAXS)) THEN C id%INFO(1)=-37 C id%INFO(2)=int(MAXS_BASE_RELAXED8/1000000_8) WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ENDIF MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) MAXS = MAXS_BASE_RELAXED8 C Note that in OOC this value of MAXS will be C overwritten if KEEP(96) .NE. 0 or if C ICNTL(23) (that is, KEEP8(4)) is provided. ELSE MAXS = 1_8 MAXS_BASE_RELAXED8 = 1_8 END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF C C If KEEP(96) is provided, C use it without asking questions C IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C C IF (KEEP(96).GT.0) THEN C -- useful mostly for internal testing: C -- we can force in this way a given value C -- of MAXS and forget about other input values C -- such as ICNTL(23) (KEEP8(4)/1D6) C -- that could change MAXS value. MAXS=int(KEEP(96),8) ELSE IF (id%KEEP8(4) .NE. 0_8) THEN C ------------------------- C WE TRY TO USE MEM_ALLOWED (KEEP8(4)/1D6) C ------------------------- C First compute what we have: TOTAL_MBYTES(PERLU) C and TOTAL_BYTES(PERLU) C PERLU_ON = .TRUE. CALL DMUMPS_MAX_MEM( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, & id%KEEP8(28), id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., KEEP(201), & PERLU_ON, TOTAL_BYTES) C C Assuming that TOTAL_BYTES is due to MAXS rather than C to the temporary buffers used for the distribution of C the matrix on the slaves (arrowheads or element distrib), C then we have: C C KEEP8(4)-TOTAL_BYTES is the extra free space C C A simple algorithm to redistribute the extra space: C All extra freedom (it could be negative !) is added to MAXS: MAXS_BASE_RELAXED8=MAXS_BASE_RELAXED8 + & (id%KEEP8(4)-TOTAL_BYTES)/int(KEEP(35),8) IF (MAXS_BASE_RELAXED8 > int(huge(MAXS),8)) THEN WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ELSE IF (MAXS_BASE_RELAXED8 .LE. 0_8) THEN C We need more space in order to at least enough id%INFO(1)=-9 IF ( -MAXS_BASE_RELAXED8 .GT. & int(huge(id%INFO(1)),8) ) THEN WRITE(*,*) "I8: OVERFLOW" CALL MUMPS_ABORT() ENDIF id%INFO(2)=-int(MAXS_BASE_RELAXED8) ELSE MAXS=MAXS_BASE_RELAXED8 ENDIF ENDIF ENDIF ENDIF ! I_AM_SLAVE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF CALL DMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & id%COMM, "effective relaxed size of S =") C Next PROPINFO is there for possible negative C values of MAXS resulting from small MEM_ALLOWED CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN C We jump after the call to LOAD_END and OOC_END since we didn't C called yet OOC_INIT and LOAD_INIT GOTO 530 ENDIF IF ( I_AM_SLAVE ) THEN C ------------------ C Dynamic scheduling C ------------------ CALL DMUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), KEEP(66), 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)-TOTAL_BYTES 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 #if ! defined(OLD_LOAD_MECHANISM) 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)) #endif IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 ! reset space allocated to zero ENDIF #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN 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 ELSE id%S => id%WK_USER(1:id%KEEP8(24)) 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 CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) CALL MUMPS_FDM_INIT('F',NB_ACTIVE_FRONTS_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_ACTIVE_FRONTS_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 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 C ---------------------------------------- IF (KEEP(38).NE.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 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) IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF 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 ) ) 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, id%I_AM_CAND, & id%CANDIDATES) C 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 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 ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) 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), id%S(1), MAXS, & 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, & & id%S(1), MAXS, & 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, & id%S(1), MAXS, 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), & id%S(1), MAXS, 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) TIME 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 slaves 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 integers, since byte is not C a standard datatype. C We now use KEEP(43) and KEEP(44) as estimated at analysis C to allocate appropriate buffer sizes. C C Reception buffer C ---------------- DMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP( 35 ), 8) C ------------------- C Ensure a reasonable C 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 PERLU = KEEP( 12 ) C For hybrid scheduling (strategy 5), Abdou C wants a minimal amount of freedom even for C small/negative PERLU values. 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(43))-100,8)) DMUMPS_LBUFR_BYTES = int( DMUMPS_LBUFR_BYTES8 ) IF (KEEP(48)==5) THEN C Since the buffer is 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 ----------- DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(43)) * dble(KEEP(35)), 8 ) 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%NSLAVES ) 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 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 the 2 send buffers 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 CALL DMUMPS_BUF_ALLOC_CB( DMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= DMUMPS_LBUF id%INFO(2)= (DMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error in DMUMPS_BUF_ALLOC_CB' & ,id%INFO(2) ENDIF GO TO 110 END IF C ----------------------------- C Allocate reception buffer and C keep it in the structure C ----------------------------- id%LBUFR_BYTES = DMUMPS_LBUFR_BYTES id%LBUFR = (DMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) IF (associated(id%BUFR)) DEALLOCATE(id%BUFR) ALLOCATE( id%BUFR( id%LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%LBUFR NULLIFY(id%BUFR) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%BFUR(', id%LBUFR,')', IERR ENDIF GO TO 110 END IF C C The buffers are declared INTEGER, because BYTE is not a C standard data type. The sizes are in bytes, so we allocate C a number of INTEGERs. The allocated size in integer is the C size in bytes divided by KEEP(34) C ------------------------------- C Allocate IS. IS will contain C factors and contribution blocks C ------------------------------- C Relax workspace at facto now C PERLU might have been modified reload initial value 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 + 2 * max(PERLU,10) * & ( MAXIS_ESTIM / 100 + 1 ) & ) IF (associated(id%IS)) DEALLOCATE( id%IS ) ALLOCATE( id%IS( MAXIS ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=MAXIS NULLIFY(id%IS) IF (LPOK) THEN WRITE(*,*) id%MYID,': Allocation error for id%IS(',MAXIS,')' ENDIF GO TO 110 END IF LIW = MAXIS C ----------------------- C Allocate PTLUST_S. PTLUST_S C is used by solve later C ----------------------- IF (associated( id%PTLUST_S )) DEALLOCATE(id%PTLUST_S) 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 100 END IF IF (associated( id%PTRFAC )) DEALLOCATE(id%PTRFAC) 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 100 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 + 3 * 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 C Store size of receive buffers in module CALL DMUMPS_BUF_DIST_IRECV_SIZE( id%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 SPMD C PERLU_ON = .TRUE. CALL DMUMPS_MAX_MEM( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) id%INFO(16) = TOTAL_MBYTES IF ( PROK ) THEN WRITE(MP,'(A,I10) ') & ' ** Space in MBYTES used during factorization :', & id%INFO(16) END IF C C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in bytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in bytes for facto, C sum over all processors C ---------------------------------------------------- C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Memory relaxation parameter ( ICNTL(14) ) :', & KEEP(12) WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for facto :', & id%INFOG(18) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during facto :', & ( id%INFOG(19)-id%INFO(16) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during facto :', & id%INFOG(19) / id%NSLAVES END IF 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 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 CALL DMUMPS_FAC_B( id%N, NSTEPS,id%S(1),MAXS,id%IS(1),LIW, & 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, id%BUFR(1),id%LBUFR, & id%LBUFR_BYTES, 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) & ) IF ( PROK .and. KEEP(38) .ne. 0 ) THEN WRITE( MP, 175 ) KEEP(49) END IF 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 ---------------- DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) 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 C next line should be enough but ... C DEALLOCATE( id%DBLARR ) 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 send buffers C They will be reallocated C in the solve. C ------------------------ IF (associated(id%BUFR)) THEN DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) END IF CALL DMUMPS_BUF_DEALL_CB( IERR ) 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 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 IF ( PROKG ) THEN IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) TIME ELSE WRITE(MPG,185) TIME ENDIF ENDIF ENDIF CC Made available to users on release 4.4 (April 2005) PERLU_ON = .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), & PERLU_ON, TOTAL_BYTES) 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 IF (PROK ) THEN WRITE(MP,'(A,I10) ') & ' ** Effective minimum Space in MBYTES for facto :', & TOTAL_MBYTES ENDIF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K69 = id%KEEP8(69) ELSE K67 = 0_8 K68 = 0_8 K69 = 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 CALL DMUMPS_AVGMAX_STAT8(PROKG, MPG, K67, id%NSLAVES, & id%COMM, "effective space used in S (KEEP8(67)) =") C C ---------------------------------------------------- C Centralize memory statistics on the host C C INFOG(21) = size of mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & TOTAL_MBYTES, id%INFOG(21), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Rank of processor needing largest memory :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Space in MBYTES used by this processor :', & id%INFOG(21) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Avg. Space in MBYTES per working proc :', & ( id%INFOG(22)-TOTAL_MBYTES ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Avg. Space in MBYTES per working proc :', & id%INFOG(22) / id%NSLAVES END IF END IF * save statistics in KEEP array. KEEP(33) = id%INFO(11) ! this should be the other way round C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations 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(6), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(6), INFOG(9)) CALL MPI_REDUCE( id%INFO(10), INFOG(10), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) 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 ============================== C LOW-RANK C ============================== IF ( KEEP(486) .GT. 0 ) THEN !LR is activated CALL MPI_REDUCE( GLOBAL_BLR_SAVINGS, TMP_GLOBAL_BLR_SAVINGS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FR_MRY, TMP_ACC_FR_MRY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_LR_FLOP_GAIN, TMP_ACC_LR_FLOP_GAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_TRSM, TMP_ACC_FLOP_FR_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_TRSM, TMP_ACC_FLOP_LR_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_UPDT, TMP_ACC_FLOP_FR_UPDT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_UPDT, TMP_ACC_FLOP_LR_UPDT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_RMB, TMP_ACC_FLOP_RMB & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_UPDT_OUT, & TMP_ACC_FLOP_LR_UPDT_OUT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_DEC_ACC, TMP_ACC_FLOP_DEC_ACC & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_REC_ACC, TMP_ACC_FLOP_REC_ACC & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_TRSM, TMP_ACC_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_PANEL, TMP_ACC_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FRFRONTS, TMP_ACC_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_DEMOTE, TMP_ACC_FLOP_DEMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_CB_DEMOTE, TMP_ACC_FLOP_CB_DEMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_CB_PROMOTE,TMP_ACC_FLOP_CB_PROMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_FACTO,TMP_ACC_FLOP_FR_FACTO & , 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 ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN & + ACC_FLOP_DEMOTE + ACC_FLOP_FRFRONTS CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,AVG_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_ACC_FLOP_LR_FACTO = AVG_ACC_FLOP_LR_FACTO/id%NPROCS ENDIF CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,MIN_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,MAX_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( ACC_UPDT_TIME,TMP_ACC_UPDT_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_DEMOTING_TIME,TMP_ACC_DEMOTING_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_CB_DEMOTING_TIME, & TMP_ACC_CB_DEMOTING_TIME, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, MASTER, & id%COMM, IERR) CALL MPI_REDUCE( ACC_PROMOTING_TIME,TMP_ACC_PROMOTING_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FRPANELS_TIME,TMP_ACC_FRPANELS_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_I_TIME,TMP_ACC_FAC_I_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_MQ_TIME,TMP_ACC_FAC_MQ_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_SQ_TIME,TMP_ACC_FAC_SQ_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_TRSM_TIME,TMP_ACC_TRSM_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FRFRONTS_TIME,TMP_ACC_FRFRONTS_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_LR_MODULE_TIME,TMP_ACC_LR_MODULE_TIME & , 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 GLOBAL_BLR_SAVINGS = TMP_GLOBAL_BLR_SAVINGS ACC_FR_MRY = TMP_ACC_FR_MRY ACC_LR_FLOP_GAIN = TMP_ACC_LR_FLOP_GAIN ACC_FLOP_TRSM = TMP_ACC_FLOP_TRSM ACC_FLOP_PANEL = TMP_ACC_FLOP_PANEL ACC_FLOP_LR_TRSM = TMP_ACC_FLOP_LR_TRSM ACC_FLOP_FR_TRSM = TMP_ACC_FLOP_FR_TRSM ACC_FLOP_LR_UPDT = TMP_ACC_FLOP_LR_UPDT ACC_FLOP_LR_UPDT_OUT = TMP_ACC_FLOP_LR_UPDT_OUT ACC_FLOP_RMB = TMP_ACC_FLOP_RMB ACC_FLOP_DEC_ACC = TMP_ACC_FLOP_DEC_ACC ACC_FLOP_REC_ACC = TMP_ACC_FLOP_REC_ACC ACC_FLOP_FR_UPDT = TMP_ACC_FLOP_FR_UPDT ACC_FLOP_DEMOTE = TMP_ACC_FLOP_DEMOTE ACC_FLOP_CB_DEMOTE = TMP_ACC_FLOP_CB_DEMOTE ACC_FLOP_CB_PROMOTE = TMP_ACC_FLOP_CB_PROMOTE ACC_FLOP_FRFRONTS = TMP_ACC_FLOP_FRFRONTS CNT_NODES = TMP_CNT_NODES ACC_FLOP_FR_FACTO = TMP_ACC_FLOP_FR_FACTO C ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN C & + ACC_FLOP_DEMOTE ACC_UPDT_TIME = TMP_ACC_UPDT_TIME /id%NPROCS ACC_DEMOTING_TIME = TMP_ACC_DEMOTING_TIME /id%NPROCS ACC_CB_DEMOTING_TIME = TMP_ACC_CB_DEMOTING_TIME/id%NPROCS ACC_PROMOTING_TIME = TMP_ACC_PROMOTING_TIME /id%NPROCS ACC_FRPANELS_TIME = TMP_ACC_FRPANELS_TIME /id%NPROCS ACC_FAC_I_TIME = TMP_ACC_FAC_I_TIME /id%NPROCS ACC_FAC_MQ_TIME = TMP_ACC_FAC_MQ_TIME /id%NPROCS ACC_FAC_SQ_TIME = TMP_ACC_FAC_SQ_TIME /id%NPROCS ACC_TRSM_TIME = TMP_ACC_TRSM_TIME /id%NPROCS ACC_FRFRONTS_TIME = TMP_ACC_FRFRONTS_TIME /id%NPROCS ACC_LR_MODULE_TIME = TMP_ACC_LR_MODULE_TIME /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110),RINFOG(3),id%NPROCS, & PROKG, MPG) FRONTWISE = 0 IF (id%KEEP(486).EQ.1) THEN C BLR was activated 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, & 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), KEEP(485), KEEP(467), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) ELSE RINFOG(14) = 0.0D00 ENDIF 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 C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(16). C Note that KEEP(17) already has the same value on all procs INFOG(28)=KEEP(112)+KEEP(17) 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 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),id%KEEP8(6),INFOG(10), & 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(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency 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 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 #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 CALL DMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8, .TRUE.) C INFO(1): input only ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') CALL MUMPS_FDM_END('F') 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 530 is done when an error occurs before C the calls to 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 FOR MATRIX DISTRIBUTION =',F12.4) 166 FORMAT(' Convergence error after scaling 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/ & ' REAL SPACE FOR FACTORS =',I16/ & ' INTEGER SPACE FOR FACTORS =',I16/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I16) 172 FORMAT(/' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' NUMBER OF WORKING PROCESSES =',I16/ & ' OUT-OF-CORE OPTION (ICNTL(22)) =',I16/ & ' REAL SPACE FOR FACTORS =',I16/ & ' INTEGER SPACE FOR FACTORS =',I16/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I16/ & ' NUMBER OF NODES IN THE TREE =',I16/ & ' MEMORY ALLOWED (MB -- 0: N/A ) =',I16/ & ' RELATIVE THRESHOLD FOR PIVOTING, CNTL(1) =',D16.4) 173 FORMAT( ' PERFORM FORWARD DURING FACTO, NRHS =',I16) 175 FORMAT(/' NUMBER OF ENTRIES FOR // ROOT =',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) =',F12.4) 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 NULL PIVOTS DETECTED BY ICNTL(16) =',I16) 99991 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(24) =',I16) 99992 FORMAT( ' INFOG(28) ESTIMATED DEFICIENCY =',I16) 99984 FORMAT(/' GLOBAL STATISTICS '/ & ' RINFOG(2) OPERATIONS IN NODE ASSEMBLY =',1PD10.3/ & ' ------(3) OPERATIONS IN NODE ELIMINATION=',1PD10.3/ & ' 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 SUBROUTINE DMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL PROKG INTEGER MPG INTEGER(8) VAL INTEGER NSLAVES INTEGER COMM CHARACTER*42 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 WRITE(MPG,100) " Maximum ", MSG, MAX_VAL WRITE(MPG,100) " Average ", MSG, int(AVG_VAL,8) ENDIF RETURN 100 FORMAT(A9,A42,I16) 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%NSLAVES) 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.1.2/src/ssol_root_parallel.F0000664000175000017500000000721313164366263017536 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), 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.1.2/src/sfac_asm_master_ELT_m.F0000664000175000017500000016306713164366263020020 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,NBPROCFILS, 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 MUMPS_BUILD_SORT_INDEX_ELT_M USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N,LIW,NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS 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))) LOGICAL SON_LEVEL2 REAL, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NBPROCFILS(KEEP(28)), NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INTEGER ETATASS LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE 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 INTEGER(8) NFRONT8, LAELL8 INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC INTEGER(8) LSTK8, SIZFR8 INTEGER SIZFI, NCB 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 NCOLS, NROWS, LDA_SON INTEGER NELIM, & IORG, IBROT 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, POINTER :: SON_IWPOS INTEGER, POINTER, DIMENSION(:) :: SON_IW REAL, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC 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 COMPRESSCB =.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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 LREQ_OOC = 0 IF (KEEP(201).EQ.1) 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) 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, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, 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)), & SLAVEF))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) 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 NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress SMUMPS_FAC_ASM_NIV1_ELT' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) #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=3000 !$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 NUMROWS = NFRONT8 TOPDIAG = max(KEEP(7), KEEP(8), KEEP(57), KEEP(58))-1 !$ 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 NASS = NASS1 PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = SON_IW(ISTCHK + 3+KEEP(IXSZ)) 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 COMPRESSCB = & ( SON_IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( SON_IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF 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) THEN K2 = K1 + LSTK - 1 IF (COMPRESSCB) 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 SIZFR8 = int(NELIM,8) * int(NELIM,8) END IF K2 = K1 + NELIM - 1 ENDIF OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) 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) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR8 ELSE LCB = int(LDA_SON,8) * int(K2-K1+1,8) ENDIF IF (LCB .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB & ) 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(SSARBR, MYID, N, ISTCHK, & IACHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 END DO 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 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 280 CONTINUE INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING SMUMPS_ASM_NIV1_ELT' ENDIF GOTO 500 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 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, & NBPROCFILS, 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 IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(40) 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 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))) REAL A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)), 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 INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 ETATASS 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(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 :: 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)) COMPRESSCB=.FALSE. ETATASS = 0 IN = INODE NBPROCFILS(STEP(IN)) = 0 NSTEPS = NSTEPS + 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)), & SLAVEF) .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) MAXFRW = max0(MAXFRW, NFRONT) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 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)), & SLAVEF) 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)), & SLAVEF) 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)), & SLAVEF) 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) 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) 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) 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) GOTO 275 CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, 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) 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) #if defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) IF ( KEEP(73) .EQ. 0 ) THEN #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 defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) ENDIF #endif #endif 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 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress SMUMPS_FAC_ASM_NIV2_ELT' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), IW(IOLDPS+XXNBPR)) #endif 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 = max(int(KEEP(361)/2,8), !$ & (LAELL8+NOMP-1) / NOMP ) !$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 ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 !$ 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 + KEEP(IXSZ) + 3) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) 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) + 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) + A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (NSLSON.EQ.0) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF IF (LCB .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & COMPRESSCB & ) 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, & 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), & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 280 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, WORKSPACE TOO SMALL DURING SMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) 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.1.2/src/Makefile0000664000175000017500000002347213164366235015174 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # # # This file is part of MUMPS 5.0beta, built on Tue Jan 10 16:43:31 UTC 2012 # topdir = .. libdir = $(topdir)/lib default: d .PHONY: default s d c z mumps_lib clean s: $(MAKE) ARITH=s mumps_lib d: $(MAKE) ARITH=d mumps_lib c: $(MAKE) ARITH=c mumps_lib z: $(MAKE) ARITH=z mumps_lib include $(topdir)/Makefile.inc mumps_lib: $(libdir)/libmumps_common$(PLAT)$(LIBEXT) \ $(libdir)/lib$(ARITH)mumps$(PLAT)$(LIBEXT) OBJS_COMMON_MOD = \ lr_common.o \ ana_omp_m.o\ ana_orderings_wrappers_m.o\ mumps_memory_mod.o\ mumps_static_mapping.o\ mumps_sol_es.o\ fac_future_niv2_mod.o\ mumps_comm_ibcast.o\ mumps_ooc_common.o\ double_linked_list.o\ fac_asm_build_sort_index_m.o\ fac_asm_build_sort_index_ELT_m.o\ omp_tps_common_m.o\ mumps_l0_omp_m.o\ front_data_mgt_m.o\ fac_maprow_data_m.o\ fac_descband_data_m.o\ fac_ibct_data_m.o OBJS_COMMON_OTHER = \ ana_orderings.o\ ana_AMDMF.o\ bcast_errors.o\ estim_flops.o\ mumps_type_size.o \ mumps_type2_blocking.o \ mumps_version.o \ tools_common.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\ ana_set_ordering.o\ mumps_numa.o \ mumps_thread.o \ mumps_save_restore_C.o OBJS_MOD = \ $(ARITH)ana_aux_par.o \ $(ARITH)ana_lr.o\ $(ARITH)fac_asm_master_m.o\ $(ARITH)fac_asm_master_ELT_m.o\ $(ARITH)omp_tps_m.o\ $(ARITH)mumps_comm_buffer.o\ $(ARITH)mumps_load.o\ $(ARITH)mumps_lr_data_m.o\ $(ARITH)mumps_ooc_buffer.o\ $(ARITH)mumps_ooc.o\ $(ARITH)mumps_struc_def.o\ $(ARITH)static_ptr_m.o\ $(ARITH)lr_core.o\ $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)fac_lr.o\ $(ARITH)fac_omp_m.o\ $(ARITH)fac_par_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_front_aux.o\ $(ARITH)fac_front_type2_aux.o\ $(ARITH)mumps_save_restore_files.o\ $(ARITH)mumps_save_restore.o OBJS_OTHER = \ $(ARITH)ini_driver.o\ $(ARITH)ana_driver.o\ $(ARITH)fac_driver.o\ $(ARITH)sol_driver.o\ $(ARITH)end_driver.o\ $(ARITH)ana_aux_ELT.o\ $(ARITH)ana_aux.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_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: $(ARITH)mumps_load.o: $(ARITH)mumps_comm_buffer.o \ $(ARITH)mumps_struc_def.o \ fac_future_niv2_mod.o $(ARITH)mumps_ooc.o: $(ARITH)mumps_struc_def.o \ $(ARITH)mumps_ooc_buffer.o \ mumps_ooc_common.o $(ARITH)mumps_ooc_buffer.o: mumps_ooc_common.o $(ARITH)ana_aux_par.o: $(ARITH)mumps_struc_def.o \ mumps_memory_mod.o \ ana_orderings_wrappers_m.o $(ARITH)mumps_comm_buffer.o: mumps_comm_ibcast.o \ $(ARITH)mumps_lr_data_m.o $(ARITH)fac_asm_master_m.o: omp_tps_common_m.o \ fac_ibct_data_m.o \ $(ARITH)omp_tps_m.o \ fac_asm_build_sort_index_m.o \ $(ARITH)mumps_comm_buffer.o \ $(ARITH)mumps_load.o $(ARITH)fac_lastrtnelind.o: $(ARITH)mumps_load.o $(ARITH)fac_asm_master_ELT_m.o: omp_tps_common_m.o \ fac_ibct_data_m.o \ $(ARITH)omp_tps_m.o \ fac_asm_build_sort_index_ELT_m.o \ $(ARITH)mumps_comm_buffer.o \ $(ARITH)mumps_load.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\ 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)ana_lr.o: $(ARITH)lr_core.o lr_common.o\ $(ARITH)lr_stats.o\ ana_orderings_wrappers_m.o $(ARITH)mumps_lr_data_m.o: $(ARITH)lr_type.o\ $(ARITH)mumps_struc_def.o $(ARITH)fac_lr.o: $(ARITH)lr_core.o\ $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)ana_lr.o $(ARITH)fac_par_m.o: $(ARITH)mumps_load.o\ $(ARITH)mumps_ooc.o\ $(ARITH)fac_lr.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\ omp_tps_common_m.o\ mumps_l0_omp_m.o $(ARITH)fac_front_aux.o : $(ARITH)mumps_comm_buffer.o\ $(ARITH)mumps_load.o\ $(ARITH)mumps_ooc.o\ mumps_ooc_common.o\ mumps_l0_omp_m.o\ mumps_comm_ibcast.o $(ARITH)fac_front_type2_aux.o : $(ARITH)mumps_ooc.o\ $(ARITH)fac_front_aux.o $(ARITH)fac_front_LU_type1.o : $(ARITH)fac_front_aux.o\ $(ARITH)mumps_ooc.o\ $(ARITH)lr_core.o\ $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)fac_lr.o $(ARITH)fac_front_LU_type2.o : $(ARITH)fac_front_aux.o\ $(ARITH)fac_front_type2_aux.o\ $(ARITH)mumps_ooc.o\ $(ARITH)lr_core.o\ $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)fac_lr.o\ fac_ibct_data_m.o $(ARITH)fac_front_LDLT_type1.o : $(ARITH)fac_front_aux.o\ $(ARITH)mumps_ooc.o $(ARITH)fac_front_LDLT_type2.o : $(ARITH)fac_front_aux.o\ $(ARITH)fac_front_type2_aux.o\ $(ARITH)mumps_ooc.o\ $(ARITH)mumps_load.o\ fac_ibct_data_m.o $(ARITH)mumps_save_restore_files.o : $(ARITH)mumps_struc_def.o $(ARITH)mumps_save_restore.o : $(ARITH)mumps_struc_def.o $(ARITH)mumps_save_restore_files.o $(ARITH)mumps_ooc.o mumps_static_mapping.o: lr_common.o fac_maprow_data_m.o: front_data_mgt_m.o fac_descband_data_m.o: front_data_mgt_m.o fac_ibct_data_m.o : front_data_mgt_m.o ana_omp_m.o: double_linked_list.o mumps_comm_ibcast.o: fac_future_niv2_mod.o fac_asm_build_sort_index_m.o: omp_tps_common_m.o fac_asm_build_sort_index_ELT_m.o:omp_tps_common_m.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) $(INCS) $(IORDERINGSF) $(ORDERINGSF) -I. -I../include -c $*.F $(OUTF)$*.o .c.o: $(CC) $(OPTC) $(INCS) -I../include $(CDEFS) $(IORDERINGSC) $(ORDERINGSC) -c $*.c $(OUTC)$*.o $(ARITH)mumps_c.o: mumps_c.c $(CC) $(OPTC) $(INCS) $(CDEFS) -DMUMPS_ARITH=MUMPS_ARITH_$(ARITH) \ $(IORDERINGSC) $(ORDERINGSC) -I../include -c mumps_c.c $(OUTC)$@ clean: $(RM) *.o *.mod MUMPS_5.1.2/src/cana_aux_par.F0000664000175000017500000027547613164366264016303 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, POINTER :: WORK1(:), WORK2(:), & 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 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 CALL CMUMPS_DO_PAR_ORD(id, ord, WORK2) 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) 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%KEEP(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 CALL CMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), & NFSIZ(1), 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 CALL CMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), NFSIZ(1), & 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, WORKERS #if defined(parmetis) || defined(parmetis3) INTEGER :: I, COLOR, BASE 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, POINTER :: 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, POINTER :: 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(MUMPS_GETSIZE(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, POINTER :: 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(MUMPS_GETSIZE(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 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)) 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) 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, POINTER :: 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(MUMPS_GETSIZE(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 = .TRUE. 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 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) 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=1, TOPNODES(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 INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR)) 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 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)) 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)) 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 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 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)) 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)) 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 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1)) 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) 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 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)) ALLOCATE(RCVBUF(2*BUFSIZE)) ALLOCATE(PENDING(NPROCS), CPNT(NPROCS)) ALLOCATE(REQ(NPROCS)) 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)) 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 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_COPY_INT_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_COPY_INT_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_COPY_INT_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_COPY_INT_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_COPY_INT_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_COPY_INT_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_COPY_INT_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_COPY_INT_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_COPY_INT_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_COPY_INT_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_COPY_INT_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_COPY_INT_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.1.2/src/dfac_mem_stack.F0000664000175000017500000005177413164366263016572 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, & IPOOL, LPOOL, LEAF, NSTK_S, & NBPROCFILS, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, & OPASSW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(40), KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, 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 ), & 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 NBPROCFILS( KEEP(28) ) 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, & NBROW_STACK, NBCOL_STACK, NELIM 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 COMPRESSCB, MUST_COMPACT_FACTORS LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE 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)),SLAVEF) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),SLAVEF) LREQCB = 0_8 INPLACE = .FALSE. COMPRESSCB= ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1) 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(*,*) "COMPRESSCB, NFRONT, NPIV, NASS, NSLAVES", & COMPRESSCB, 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 KEEP8(10) = KEEP8(10) + int(NPIV,8) * int(NFRONT,8) ELSE KEEP8(10) = KEEP8(10) + ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF KEEP8(10) = KEEP8(10) + int(NBROW,8) * int(NPIV,8) 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 ) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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)),SLAVEF) 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, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), SLAVEF ) 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 ), COMPRESSCB, & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) .EQ. MYID ) THEN LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_SEND = 0 IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NBROW ELSE NBCOL_STACK = NBCOL ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBCOL_STACK = NBCOL LREQI = 6 + NBROW_STACK + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (COMPRESSCB) THEN LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 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, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .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 (COMPRESSCB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (COMPRESSCB) 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 ( 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 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, COMPRESSCB, & 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, COMPRESSCB ) 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 NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND 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 KEEP8(8)=KEEP8(8) + int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF 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) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE DMUMPS_FAC_STACK MUMPS_5.1.2/src/zfac_omp_m.F0000664000175000017500000000117613164366266015756 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C C SUBROUTINE ZMUMPS_FAC_L0_OMP_RETURN() C C Research work on multithreaded tree parallelism initiated in C the context of the PhD thesis of Wissam Sid-Lakhdar (ENS Lyon) C might impact a future release. C RETURN END SUBROUTINE ZMUMPS_FAC_L0_OMP_RETURN MUMPS_5.1.2/src/cbcast_int.F0000664000175000017500000000276113164366264015754 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/sfac_asm_master_m.F0000664000175000017500000017204313164366263017306 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,NBPROCFILS, 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 MUMPS_BUILD_SORT_INDEX_M USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N,LIW,NSTEPS INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 REAL, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NBPROCFILS(KEEP(28)), NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) 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 ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE 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 INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8 INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC INTEGER(8) :: SIZFR8 INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM, & IBROT,IORG 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 INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE, OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER, POINTER :: SON_IWPOS INTEGER, POINTER, DIMENSION(:) :: SON_IW REAL, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 COMPRESSCB =.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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)), & SLAVEF) 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 LREQ_OOC = 0 IF (KEEP(201).EQ.1) 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) 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)),SLAVEF) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF END IF END IF END IF END IF NIV1 = .TRUE. CALL MUMPS_BUILD_SORT_INDEX( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, 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)), & SLAVEF))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) 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 NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF IF (LRLU .LT. LAELL_REQ8) THEN IF (LRLUS .LT. LAELL_REQ8) THEN IF (LPOK) THEN WRITE(LP, * ) ' NOT ENOUGH MEMORY during ASSEMBLY ', & ' MEMORY REQUESTED = ', LAELL_REQ8, & ' AVAILABLE =', LRLUS ENDIF GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 4 after compress ' WRITE(LP, * ) 'IN SMUMPS_FAC_ASM_NIV1' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 + SIZE_ISON_TOP8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 + SIZE_ISON_TOP8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) #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=3000 !$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 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 TOPDIAG = max(KEEP(7), KEEP(8))-1 !$ 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 ) TOPDIAG = max(KEEP(7), KEEP(8), KEEP(57), KEEP(58))-1 !$ 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)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 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_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) 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 COMPRESSCB = & ( SON_IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( SON_IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF 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) THEN K2 = K1 + LSTK - 1 IF (COMPRESSCB) THEN SIZFR8 = (int(LSTK,8)*int(LSTK+1,8))/2_8 ELSE SIZFR8 = int(LSTK,8)*int(LSTK,8) ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * int(LSTK,8) ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) 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.300) !$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) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR8 ELSE LCB = int(LDA_SON,8) * int(K2-K1+1,8) ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL SMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB) ELSE IF (LCB .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB & ) 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(SSARBR, MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 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 280 CONTINUE INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL_REQ8 - LRLUS, INFO(2)) IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL 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 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, & NBPROCFILS, 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 IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(40) 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 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 NBPROCFILS(KEEP(28)), & 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 INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER,I INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 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 !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. COMPRESSCB = .FALSE. ETATASS = 0 IN = INODE NBPROCFILS(STEP(IN)) = 0 NSTEPS = NSTEPS + 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)), & SLAVEF) .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 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)), & SLAVEF) 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)), & SLAVEF) 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) 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) 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) 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) GOTO 275 ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, 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) 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) #if defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) IF ( KEEP(73) .EQ. 0 ) THEN #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 defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) ENDIF #endif #endif 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 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 3 after compress ' WRITE(LP, * ) 'IN SMUMPS_FAC_ASM_NIV2' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 = max(int(KEEP(361)/2,8), !$ & (LAELL8+NOMP-1) / NOMP ) !$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 !$ 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 COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) 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) + 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) + A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (NSLSON.EQ.0) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF IF (LCB .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & COMPRESSCB & ) 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, & 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), & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 280 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) 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.1.2/src/fac_future_niv2_mod.F0000664000175000017500000000074613164366241017557 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/mumps_io_thread.c0000664000175000017500000004354713164366240017060 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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); /* 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 LREQ_OOC = 0 IF (KEEP(201).EQ.1) 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) 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)),SLAVEF) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF END IF END IF END IF END IF NIV1 = .TRUE. CALL MUMPS_BUILD_SORT_INDEX( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, 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)), & SLAVEF))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) 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 NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF IF (LRLU .LT. LAELL_REQ8) THEN IF (LRLUS .LT. LAELL_REQ8) THEN IF (LPOK) THEN WRITE(LP, * ) ' NOT ENOUGH MEMORY during ASSEMBLY ', & ' MEMORY REQUESTED = ', LAELL_REQ8, & ' AVAILABLE =', LRLUS ENDIF GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 4 after compress ' WRITE(LP, * ) 'IN CMUMPS_FAC_ASM_NIV1' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 + SIZE_ISON_TOP8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 + SIZE_ISON_TOP8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) #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=3000 !$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 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 TOPDIAG = max(KEEP(7), KEEP(8))-1 !$ 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 ) TOPDIAG = max(KEEP(7), KEEP(8), KEEP(57), KEEP(58))-1 !$ 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)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 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_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) 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 COMPRESSCB = & ( SON_IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( SON_IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF 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) THEN K2 = K1 + LSTK - 1 IF (COMPRESSCB) THEN SIZFR8 = (int(LSTK,8)*int(LSTK+1,8))/2_8 ELSE SIZFR8 = int(LSTK,8)*int(LSTK,8) ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * int(LSTK,8) ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) 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.300) !$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) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR8 ELSE LCB = int(LDA_SON,8) * int(K2-K1+1,8) ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL CMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB) ELSE IF (LCB .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB & ) 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(SSARBR, MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 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 280 CONTINUE INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL_REQ8 - LRLUS, INFO(2)) IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL 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 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, & NBPROCFILS, 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(40) 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 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 NBPROCFILS(KEEP(28)), & 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 INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER,I INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 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 !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. COMPRESSCB = .FALSE. ETATASS = 0 IN = INODE NBPROCFILS(STEP(IN)) = 0 NSTEPS = NSTEPS + 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)), & SLAVEF) .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 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)), & SLAVEF) 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)), & SLAVEF) 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) 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) 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) 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) GOTO 275 ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, 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) 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) #if defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) IF ( KEEP(73) .EQ. 0 ) THEN #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 defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) ENDIF #endif #endif 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 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 3 after compress ' WRITE(LP, * ) 'IN CMUMPS_FAC_ASM_NIV2' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 = max(int(KEEP(361)/2,8), !$ & (LAELL8+NOMP-1) / NOMP ) !$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 !$ 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 COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) 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) + 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) + A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (NSLSON.EQ.0) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF IF (LCB .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & COMPRESSCB & ) 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, & 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), & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 280 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) 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.1.2/src/dfac_process_master2.F0000664000175000017500000001477313164366263017740 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, FRERE, & ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE DMUMPS_LOAD 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 ), 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' 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, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, 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 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 IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & SLAVEF) .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(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, & SLAVEF, 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.1.2/src/csol_bwd.F0000664000175000017500000012206713164366264015441 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NA, LNA, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, 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 & , TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE CMUMPS_OOC USE CMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER(8), intent(in) :: LWC INTEGER N,LIW,LIWW,LPOOL,LNA INTEGER SLAVEF,MYLEAF,COMM,MYID INTEGER LPANEL_POS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NA(LNA),NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(40), INFO(40) 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) #if defined(RHSCOMP_BYROWS) COMPLEX RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX RHSCOMP(LRHSCOMP,NRHS) #endif INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) 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 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INTEGER POSIWCB,K INTEGER(8) :: APOS, IST INTEGER(8) :: IFR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB,NBFINF INTEGER NBLEAF,INODE,NBROOT,NROOT,NBFILS INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER III,IIPOOL,MYLEAFE INTEGER NSLAVES INTEGER JBDEB, JBFIN, NRHS_B COMPLEX ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0E0,0.0E0), & ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) LOGICAL BLOQ,DEBUT INTEGER PROCDEST, DEST INTEGER POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL, & IPOSINRHSCOMP_TMP INTEGER DUMMY(1) INTEGER(8) :: POSWCB, PLEFTW, PTWCB INTEGER Offset, EffectiveSize, ISLAVE, FirstIndex LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INCLUDE 'mumps_headers.h' LOGICAL BLOCK_SEQUENCE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL Exploit_Sparsity, AM1 DOUBLE PRECISION :: TIME_TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok 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 LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER MUMPS_TYPENODE EXTERNAL cgemv, ctrsv, ctrsm, cgemm, & MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR 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 NROOT = 0 NBLEAF = NA(1) NBROOT = NA(2) DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) .EQ. MYID) THEN NROOT = NROOT + 1 IPOOL(NROOT) = INODE ENDIF END DO III = 1 IIPOOL = NROOT + 1 BLOCK_SEQUENCE = .FALSE. Exploit_Sparsity = .FALSE. AM1 = .FALSE. IF (KEEP(235).NE.0) Exploit_Sparsity = .TRUE. IF (KEEP(237).NE.0) AM1 = .TRUE. NO_CHILDREN = .FALSE. IF (Exploit_Sparsity .OR. AM1) MYLEAF = -1 IF (MYLEAF .EQ. -1) THEN MYLEAF = 0 DO I=1, NBLEAF INODE=NA(I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) .EQ. MYID) THEN MYLEAF = MYLEAF + 1 ENDIF ENDDO ENDIF MYLEAFE=MYLEAF NBFINF = SLAVEF IF (MYLEAFE .EQ. 0) THEN CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) THEN GOTO 340 ENDIF ENDIF 50 CONTINUE 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 GO TO 60 ENDIF END IF IF ( NBFINF .eq. 0 ) GOTO 340 GOTO 50 IF (MYID.EQ.0) write(6,*) "BWD: process INODE=", INODE 60 CONTINUE 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO JJ = J1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP_TMP) = RHS_ROOT(IFR+NPIV*(K-1)) #else RHSCOMP(IPOSINRHSCOMP_TMP,K) = RHS_ROOT(IFR+NPIV*(K-1)) #endif END DO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE CALL CMUMPS_SOL_CPY_FS2RHSCOMP(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) ENDIF IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 ENDIF GOTO 50 ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( AM1 ) 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 DEBUT = .TRUE. DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( AM1 ) 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)),SLAVEF) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & SLAVEF) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) GOTO 330 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF ( IERR .NE. 0 ) CALL MUMPS_ABORT() ENDIF IF = FRERE(STEP(IF)) ENDDO IF (AM1 .AND.NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 ENDIF 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 GOTO 50 END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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)) GOTO 330 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 330 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2 - KEEP(253) J = IW(JJ) IFR = IFR + 1_8 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN W(IFR+int(K-JBDEB,8)*int(NCB,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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) ELSE WRITE(*,*) "Internal error CMUMPS_SOL_S" CALL MUMPS_ABORT() END IF 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 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) GOTO 50 ENDIF 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) 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 330 ENDIF ENDIF APOS = PTRFAC(IW(IPOS)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1) 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)) GOTO 330 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) ) GOTO 330 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 330 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(350).eq.0) THEN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = ZERO ENDDO ELSE DO JJ = J1, J2 #if defined(RHSCOMP_BYROWS) W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif ENDDO ENDIF ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = ZERO ENDDO ENDIF ELSE WRITE(*,*) "Internal error CMUMPS_SOL_BWD" CALL MUMPS_ABORT() 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1_8 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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) ELSE WRITE(*,*) "Internal error CMUMPS_SOL_S" CALL MUMPS_ABORT() ENDIF 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) 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 (KEEP(350).EQ.0) THEN CALL cgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( PTWCB_PANEL+int(NBJ,8) ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ELSE IF (NCB_PANEL - NCB.NE. 0) THEN CALL cgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), & 1, ONE, & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif 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, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF ENDIF ENDIF IF (MTYPE.NE.1) THEN IF (KEEP(350).eq.0) THEN CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ELSE IF (KEEP(350).eq.0) THEN CALL ctrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL ctrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (KEEP(350).eq.0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(PTWCB_PANEL+int(NBJ,8)),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in CMUMPS_SOL_S" CALL MUMPS_ABORT() #else 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 ENDIF ENDIF IF (MTYPE.NE.1) THEN IF (KEEP(350).eq.0) THEN CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in CMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF ELSE IF (KEEP(350).eq.0) THEN CALL ctrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in CMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL ctrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ENDIF IF (KEEP(201).EQ.0.OR.KEEP(201).EQ.2)THEN 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 IF (KEEP(350).EQ.0) THEN CALL cgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & W(PTWCB), 1 ) ELSE CALL cgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL cgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & W(PTWCB), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in CMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL cgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #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 IF (KEEP(350).EQ.0) THEN CALL cgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB+int(NPIV,8) ), & 1, ONE, & W(PTWCB), 1 ) ELSE CALL cgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL cgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, W(PTWCB),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in CMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL cgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB),LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL ctrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL ctrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL ctrsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), & LIELL, W(PTWCB), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in CMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL ctrsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), & LIELL, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE LDAJ=NPIV ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL ctrsv('U','N','U', NPIV, A(APOS), LDAJ, & W(PTWCB), 1) ELSE CALL ctrsv('U','N','U', NPIV, A(APOS), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL ctrsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), & LDAJ,W(PTWCB),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in CMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL ctrsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), & LDAJ, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif END IF 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO 150 I = 1, NPIV DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP_TMP) = W(PTWCB+I-1+(K-JBDEB)*LIELL) #else RHSCOMP(IPOSINRHSCOMP_TMP, K) = W(PTWCB+I-1+(K-JBDEB)*LIELL) #endif ENDDO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 150 CONTINUE ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*)"Internal error in CMUMPS_SOL_S" CALL MUMPS_ABORT() ENDIF 160 CONTINUE IF (KEEP(201).GT.0) 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 330 ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 ENDIF GOTO 50 ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF (AM1) 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 ( AM1 ) 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 (AM1 .AND. NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 ENDIF ENDIF ELSE DEBUT = .TRUE. DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( AM1 ) 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)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),SLAVEF) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 330 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF (AM1 .AND. NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 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 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 GOTO 50 330 CONTINUE CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, & SLAVEF, KEEP) 340 CONTINUE CALL CMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE CMUMPS_SOL_S MUMPS_5.1.2/src/front_data_mgt_m.F0000664000175000017500000002213113164366241017133 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 -- not used currently C except for type 2 symmetric active fronts C to store block-low-rank information. C This mechanism should be generalized to C store low-rank information of all fronts C that will be passed from factorization to C solve (which implies keeping track of them C in the main MUMPS structure). 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 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 1 in MUMPS_FDM_END", WHAT CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_FDM_END C 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 RETURN 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 #if defined(DBG_FDM) WRITE(*,*) "DBG_FDM: IWHANDLER=",IWHANDLER, "Starting FROM=",FROM #endif 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 #if defined(DBG_FDM) WRITE(*,*) "DBG_FDM: IWHANDLER=",IWHANDLER, "Ending FROM=",FROM #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 END MODULE MUMPS_FRONT_DATA_MGT_M MUMPS_5.1.2/src/sfac_process_contrib_type2.F0000664000175000017500000003376513164366262021166 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, 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 IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ), FILS( N ) 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 'mumps_headers.h' 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 #if ! defined(NO_XXNBPR) INTEGER :: INBPROCFILS_SON #endif 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 ) MASTER = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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) 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 ) CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN 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 ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress SMUMPS_PROCESS_CONTRIB_TYPE2' WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR( LREQA - LRLUS, IERROR ) CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END IF END IF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQA KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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 NBPROCFILS(STEP(INODE))=NBPROCFILS(STEP(INODE))-NBROW #if ! defined(NO_XXNBPR) IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW #endif 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 ) 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 ) 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 CALL SMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ELSE 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 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 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - DECR NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB #if ! defined(NO_XXNBPR) 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 #endif #if ! defined(NO_XXNBPR) IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN #endif 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_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF #if ! defined(NO_XXNBPR) IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN #else IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN #endif CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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.1.2/src/sfac_asm.F0000664000175000017500000005647413164366262015427 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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(8) :: POSELT 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)) POSELT = PTRAST(STEP(INODE)) 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, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), & RHS_MUMPS) 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) IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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 INCLUDE 'mumps_headers.h' INTRINSIC real IOLDPS = PTRIST(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) 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(APOS+int(J-1,8)) = A( 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(K8) = A(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(APOS:APOS+int(NBCOLS-IDIAG-1,8))= & A(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(K8) = A(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 & ) 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 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.300 !$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)) & A(JJ2) = VALSON(JJ1) 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) 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) 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 :: 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)) A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = ZERO NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) 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 MUMPS_5.1.2/src/cmumps_lr_data_m.F0000664000175000017500000005411613164366265017153 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_PANEL_LORU, & CMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & CMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & CMUMPS_BLR_RETRIEVE_PANEL_L, & CMUMPS_BLR_RETRIEVE_PANEL_LORU, & CMUMPS_BLR_DEC_AND_TRYFREE_L, & CMUMPS_BLR_TRY_FREE_PANEL, & CMUMPS_BLR_FREE_ALL_PANELS, & CMUMPS_BLR_FREE_PANEL TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(lrb_type), pointer :: LRB_PANEL(:) END TYPE blr_panel_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 INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333) 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) 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) ENDDO RETURN END SUBROUTINE CMUMPS_BLR_INIT_MODULE SUBROUTINE CMUMPS_BLR_END_MODULE(INFO1, KEEP8, IS_FACTOR) INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: I, ILOOP IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF ILOOP=0 DO I=1, size(BLR_ARRAY) ILOOP= ILOOP+1 IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U)) THEN IF (INFO1 .GE.0) THEN WRITE(*,*) "Internal error 2 in MUMPS_BLR_END_MODULE ", & " IWHANDLER=", I CALL MUMPS_ABORT() ELSE CALL CMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, IS_FACTOR) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE CMUMPS_BLR_END_MODULE SUBROUTINE CMUMPS_BLR_INIT_FRONT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error in CMUMPS_BLR_INIT_FRONT ", & NB_PANELS ENDIF CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) 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 RETURN 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) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) ELSE ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (associated(BEGS_BLR_COL)) THEN INFO(2)=size(BEGS_BLR_L)+size(BEGS_BLR_COL) ELSE INFO(2)=size(BEGS_BLR_L) ENDIF RETURN ENDIF ELSE IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(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_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN INFO(2)=NB_PANELS+size(BEGS_BLR_L)+size(BEGS_BLR_COL) ELSE IF (IsSYM) THEN INFO(2)=NB_PANELS+size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+size(BEGS_BLR_L) ENDIF RETURN 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 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 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_INIT_FRONT SUBROUTINE CMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, & KEEP8, IS_FACTOR) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) THEN RETURN 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) THEN WRITE(*,*) " Internal Error 2 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, IS_FACTOR) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF ENDIF ENDDO NULLIFY(THEPANEL%LRB_PANEL) 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) THEN WRITE(*,*) " Internal Error 2 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, IS_FACTOR) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF ENDIF ENDDO NULLIFY(THEPANEL%LRB_PANEL) IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF ENDIF IF (.NOT. associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER CALL MUMPS_ABORT() ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) 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 CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) 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 ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 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_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_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_PANEL_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_RETRIEVE_PANEL_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_RETRIEVE_PANEL_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_RETRIEVE_PANEL_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_RETRIEVE_PANEL_L 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", & "IPANEL=", IPANEL 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", & "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_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF 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 ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 2 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(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_U(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT - 1 ENDIF RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE CMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8, IS_FACTOR) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR 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, IS_FACTOR) RETURN END SUBROUTINE CMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE CMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE CMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE CMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO 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 (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_BLR_FREE_ALL_PANELS SUBROUTINE CMUMPS_BLR_FREE_PANEL( IWHANDLER, LORU, IPANEL, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: LORU INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF (LORU.EQ.0.or.LORU.EQ.1) THEN IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ELSE 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE CMUMPS_BLR_FREE_PANEL END MODULE CMUMPS_LR_DATA_M MUMPS_5.1.2/src/dsol_c.F0000664000175000017500000026352213164366263015111 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, PTR_RHS_ROOT, LPTR_RHS_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 , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS & ) USE DMUMPS_OOC USE MUMPS_SOL_ES IMPLICIT NONE INCLUDE 'dmumps_root.h' #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(40),INFO(40), KEEP(500) 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)) #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION :: RHSCOMP(NRHS, LRHSCOMP) #else DOUBLE PRECISION :: RHSCOMP(LRHSCOMP,NRHS) #endif 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) :: LPTR_RHS_ROOT DOUBLE PRECISION PTR_RHS_ROOT(LPTR_RHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,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 INTEGER IZERO 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 PARAMETER (IZERO = 0 ) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mumps_headers.h' 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) :: LPTR_RHS_BOUNDS INTEGER, intent(inout) :: PTR_RHS_BOUNDS (LPTR_RHS_BOUNDS) DOUBLE PRECISION, intent(inout) :: DKEEP(230) 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, DIMENSION(:), ALLOCATABLE :: prun_NA INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP, INODE_PRINC LOGICAL AM1, DO_PRUN LOGICAL Exploit_Sparsity LOGICAL DO_NBSPARSE_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 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 = KEEP(28)+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 IF (.not. allocated(Pruned_SONS)) 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 END IF IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (.not. allocated(TO_PROCESS)) THEN SIZE_TO_PROCESS = KEEP(28) 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 END IF TO_PROCESS(:) = .TRUE. ENDIF 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 MUMPS_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 MUMPS_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 MUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), 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 MUMPS_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), & PTR_RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL MUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, PTR_RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, & 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 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 DMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE, & FROM_PP & ) ELSE ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), & STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves+nb_prun_roots+2 END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 prun_NA(1) = nb_prun_leaves prun_NA(2) = nb_prun_roots DO I = 1, nb_prun_leaves prun_NA(I+2) = Pruned_Leaves(I) ENDDO DO I = 1, nb_prun_roots prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) ENDDO DEALLOCATE(Pruned_List) DEALLOCATE(Pruned_Leaves) IF (AM1) THEN DEALLOCATE(Pruned_Roots) END IF IF ((Exploit_Sparsity).AND.(nb_prun_roots.EQ.NA(2))) THEN DEALLOCATE(Pruned_Roots) IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) SWITCH_OFF_ES = .TRUE. ENDIF CALL DMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & Pruned_SONS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) DEALLOCATE(prun_NA) 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. 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 MUMPS_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 MUMPS_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 MUMPS_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 PTR_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, & PTR_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 (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF 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 ( AM1 ) THEN CALL MUMPS_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 MUMPS_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 MUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL MUMPS_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), & PTR_RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL MUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, PTR_RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, & 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 = IZERO 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 PTR_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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,II) = ZERO #else RHSCOMP(II, K) = ZERO #endif ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN ) THEN SIZE_TO_PROCESS = 1 IF (allocated(TO_PROCESS)) DEALLOCATE(TO_PROCESS) ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) TO_PROCESS(:) = .TRUE. 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, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, DKEEP, & PTR_RHS_ROOT, LPTR_RHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE_BWD, & FROM_PP & ) ELSE ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), & STAT=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of prun_na' CALL MUMPS_ABORT() END IF prun_NA(1) = nb_prun_leaves prun_NA(2) = nb_prun_roots DO I = 1, nb_prun_leaves prun_NA(I+2) = Pruned_Leaves(I) ENDDO DO I = 1, nb_prun_roots prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) ENDDO 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, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & PTR_RHS_ROOT, LPTR_RHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP) ENDIF #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 #if defined(RHSCOMP_BYROWS) K = min0(10,size(RHSCOMP,2)) IF (LDIAG.EQ.4) K = size(RHSCOMP,2) WRITE (MP,99992) IF (size(RHSCOMP,2).GT.0) & WRITE (MP,99993) (RHSCOMP(1,I),I=1,K) IF (size(RHSCOMP,2).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSCOMP(2,I),I=1,K) #else K = min0(10,size(RHSCOMP,1)) IF (LDIAG.EQ.4) K = size(RHSCOMP,1) 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(prun_NA)) DEALLOCATE (prun_NA) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (first column)'/(1X,1P,5D14.6)) 99994 FORMAT (' RHS (2 nd column)'/(1X,1P,5D14.6)) 99992 FORMAT (//' LEAVING SOLVE (MPI41C) 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) #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION, intent(in) :: RHSCOMP(NCOL_RHSCOMP, LRHSCOMP) #else DOUBLE PRECISION, intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) #endif 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 PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP INTEGER SK38, SK20 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 MUMPS_PROCNODE 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 = N/2 !$ 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)) !$ 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) # else RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) # endif 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) # else RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) # endif 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 = N/2 !$ 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)) !$ 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = RHSCOMP(J,IPOSINRHSCOMP) # else RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) # endif 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = RHSCOMP(J,IPOSINRHSCOMP) # else RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) # endif 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 defined(RHSCOMP_BYROWS) IF (LCWORK .LT. NRHS) THEN WRITE(*,*) MYID, & ": Internal error 2 in DMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF #else 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 #endif IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247))) 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 (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) THEN IPOS = PTRIST(ISTEP)+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV 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 (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) #if defined(RHSCOMP_BYROWS) DO I=1,NPIV II=IROWLIST(I) CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NRHS, MPI_DOUBLE_PRECISION, & COMM, IERR) IF (LSCAL.AND.KEEP(242).EQ.0) THEN DO J=1,NRHS JCOL_RHS = J+JBEG_RHS-1 RHS(II,JCOL_RHS) = CWORK(J)*SCALING(II) ENDDO ELSE IF ((.NOT. LSCAL).AND.(KEEP(242).EQ.0)) THEN DO J=1,NRHS JCOL_RHS = J+JBEG_RHS-1 RHS(II,JCOL_RHS) = CWORK(J) ENDDO ELSE IF (LSCAL.AND.KEEP(242).NE.0) THEN DO J=1,NRHS JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) RHS(II,JCOL_RHS) = CWORK(J)*SCALING(II) ENDDO ELSE DO J=1,NRHS JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) RHS(II,JCOL_RHS) = CWORK(J) ENDDO ENDIF ENDDO #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 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 #endif 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 defined(RHSCOMP_BYROWS) IF (KEEP(242).EQ.0) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) IF (LSCAL) THEN DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) ENDDO ELSE DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(J,IPOSINRHSCOMP) ENDDO ENDIF ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(J,IPOSINRHSCOMP) IF (LSCAL) THEN RHS(I,PERM_RHS(J+JBEG_RHS-1)) = RHS(I,PERM_RHS(J+JBEG_RHS-1))*SCALING(I) ENDIF ENDDO ENDDO ENDIF #else 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) 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) DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF 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)) #if defined(RHSCOMP_BYROWS) DO II=1,NPIV DO J=1, NRHS CWORK(J) = RHSCOMP(J,IPOSINRHSCOMP+II-1) ENDDO CALL MPI_PACK(CWORK(1), NRHS, & MPI_DOUBLE_PRECISION, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO #else DO J=1,NRHS CALL MPI_PACK(RHSCOMP(IPOSINRHSCOMP,J), NPIV, & MPI_DOUBLE_PRECISION, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO #endif 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 #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION, intent(in) :: RHSCOMP (NRHSCOMP_COL,LRHSCOMP) #else DOUBLE PRECISION, intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL) #endif 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 #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)= & RHSCOMP(K,IPOSINRHSCOMP)*SCALING(I) #else RHS_SPARSE_COPY(IZ)= & RHSCOMP(IPOSINRHSCOMP,K)*SCALING(I) #endif ELSE #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)=RHSCOMP(K,IPOSINRHSCOMP) #else RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) #endif 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 #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)=RHSCOMP(K,IPOSINRHSCOMP) #else RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) #endif 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) 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 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 INTEGER SK38,SK20 INCLUDE 'mumps_headers.h' IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 DO JJ=J1,J1+NPIV-1 K=K+1 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 ) # if defined(RHSCOMP_BYROWS) DOUBLE PRECISION RHSCOMP( NBRHS_EFF, LRHSCOMP ) # else DOUBLE PRECISION RHSCOMP( LRHSCOMP, NBRHS_EFF ) # endif 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), & SLAVEF)) 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 ((KEEP(242) .EQ. 0).AND.(KEEP(350).EQ.0)) THEN KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 IPOSINRHSCOMP = POSINRHSCOMP(IW(JJ)) IF (NB_RHSSKIPPED.GT.0) THEN SOL_LOC(KLOC, BEG_RHS:JEMPTY) = ZERO ENDIF IF (LSCAL) THEN # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(1:NBRHS_EFF,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,1:NBRHS_EFF) # endif ELSE # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JEMPTY+1:JEND) = & RHSCOMP(1:NBRHS_EFF,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JEMPTY+1:JEND) = & RHSCOMP(IPOSINRHSCOMP,1:NBRHS_EFF) # endif ENDIF ENDDO ELSE 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+1) .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 # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(JCOL-JEMPTY,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) # endif ELSE # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(JCOL-JEMPTY,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) # endif ENDIF ENDDO ENDDO !$OMP END PARALLEL DO ENDIF 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(40), INFO(40) DOUBLE PRECISION, intent(in) :: RHS (LRHS, NCOL_RHS) #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION, intent(out) :: RHSCOMP(NCOL_RHSCOMP, LRHSCOMP) #else DOUBLE PRECISION, intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) #endif 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 SK38, SK20 !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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 #if defined(RHSCOMP_BYROWS) DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP DO K=1, NCOL_RHSCOMP RHSCOMP (K, I) = ZERO ENDDO ENDDO #else DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO #endif 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& FIRSTPRIVATE(BUF_EFFSIZE) 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 #if defined(RHSCOMP_BYROWS) DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP DO K=1, NCOL_RHSCOMP RHSCOMP (K, I) = ZERO ENDDO ENDDO #else DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO #endif ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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)) END IF 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 defined(RHSCOMP_BYROWS) DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSCOMP( K, INDX+JJ-J1 ) = RHS( J, K ) ENDDO ENDDO #else 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(J1,NPIV,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 #endif 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& FIRSTPRIVATE(BUF_EFFSIZE) IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) #if defined(RHSCOMP_BYROWS) RHSCOMP( K, INDX ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE ) #else RHSCOMP( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) #endif 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 #if defined(RHSCOMP_BYROWS) RHSCOMP( K, INDX ) = BUF_RHS( K, I ) #else RHSCOMP( INDX, K ) = BUF_RHS( K, I ) #endif 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 SK38, SK20, IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 SK38, SK20, 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 IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 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.1.2/src/mumps_size.c0000664000175000017500000000106313164366240016057 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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_INT *diff) { *diff = (MUMPS_INT) (b - a); } MUMPS_5.1.2/src/cend_driver.F0000664000175000017500000003156413164366266016134 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) 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%PROCNODE)) THEN DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) 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 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 -------------- C Receive buffer C -------------- IF ( associated( id%BUFR ) ) DEALLOCATE( id%BUFR ) NULLIFY( id%BUFR ) 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_AFTER_L0_OMP)) THEN DEALLOCATE(id%IPOOL_AFTER_L0_OMP) NULLIFY(id%IPOOL_AFTER_L0_OMP) END IF IF (associated(id%IPOOL_BEFORE_L0_OMP)) THEN DEALLOCATE(id%IPOOL_BEFORE_L0_OMP) NULLIFY(id%IPOOL_BEFORE_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%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 RETURN END SUBROUTINE CMUMPS_END_DRIVER MUMPS_5.1.2/src/ana_orderings_wrappers_m.F0000664000175000017500000006531413164366241020713 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_COPY_INT_64TO32(IPE8, NCMP+1, IPE) CALL METIS_NODEWND(NCMP, IPE, IW,FRERE, & NUMFLAG, OPTIONS_METIS, & IKEEP2, IKEEP1 ) CALL MUMPS_COPY_INT_32TO64(IPE, NCMP+1, IPE8) 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_COPY_INT_64TO32(IPE8, NCMP+1, IPE) CALL METIS_NODEND(NCMP, IPE, IW, & NUMFLAG, OPTIONS_METIS, & IKEEP2, IKEEP1 ) CALL MUMPS_COPY_INT_32TO64(IPE, NCMP+1, IPE8) 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_COPY_INT_64TO32(IPE8, NCMP+1, IPE) CALL METIS_NODEND( NCMP, IPE, IW, FRERE, & OPTIONS_METIS, IKEEP2, IKEEP1) CALL MUMPS_COPY_INT_32TO64(IPE, NCMP+1, IPE8) 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 ) 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 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IW8, FRERE8, & IKEEP18, IKEEP28 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL METIS_NODEWND(NCMP, IPE8, IW ,FRERE, & NUMFLAG, OPTIONS_METIS, & IKEEP2, IKEEP1 ) ELSE ALLOCATE(IW8(IPE8(NCMP+1)-1_8), FRERE8(NCMP), & IKEEP18(NCMP), IKEEP28(NCMP), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* ( & IPE8(NCMP+1)-1_8+3_8*int(NCMP,8) & ) & , INFO(2) & ) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEWND_MIXEDto64" RETURN ENDIF CALL MUMPS_COPY_INT_32TO64_64C(IW , IPE8(NCMP+1)-1_8, IW8 ) CALL MUMPS_COPY_INT_32TO64 (FRERE, NCMP , FRERE8) CALL METIS_NODEWND(NCMP, IPE8, IW8,FRERE8, & NUMFLAG, OPTIONS_METIS, & IKEEP2, IKEEP1 ) CALL MUMPS_COPY_INT_64TO32(IKEEP18, NCMP, IKEEP1) CALL MUMPS_COPY_INT_64TO32(IKEEP28, NCMP, IKEEP2) DEALLOCATE(IW8, FRERE8, IKEEP18, IKEEP28) 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 ) 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), ALLOCATABLE, DIMENSION(:) :: IW8, & IKEEP18, IKEEP28 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL METIS_NODEND(NCMP, IPE8, IW, & NUMFLAG, OPTIONS_METIS, & IKEEP2, IKEEP1 ) ELSE ALLOCATE(IW8(IPE8(NCMP+1)-1_8), & IKEEP18(NCMP), IKEEP28(NCMP), 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 memory allocation in METIS_METIS_NODEND_MIXEDto64" RETURN ENDIF CALL MUMPS_COPY_INT_32TO64_64C(IW , IPE8(NCMP+1)-1_8, IW8 ) CALL METIS_NODEND(NCMP, IPE8, IW8, & NUMFLAG, OPTIONS_METIS, & IKEEP28, IKEEP18 ) CALL MUMPS_COPY_INT_64TO32(IKEEP18, NCMP, IKEEP1) CALL MUMPS_COPY_INT_64TO32(IKEEP28, NCMP, IKEEP2) DEALLOCATE(IW8, IKEEP18, IKEEP28) 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 ) 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), ALLOCATABLE, DIMENSION(:) :: IW8, FRERE8, & IKEEP18, IKEEP28, & OPTIONS_METIS8 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL METIS_NODEND( NCMP, IPE8, IW, FRERE, & OPTIONS_METIS, IKEEP2, IKEEP1 ) ELSE ALLOCATE(IW8(IPE8(NCMP+1)-1_8), 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)* ( & IPE8(NCMP+1)-1_8+3_8*int(NCMP,8)+int(LOPTIONS_METIS,8) & ) & , INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEND_MIXEDto64" RETURN ENDIF CALL MUMPS_COPY_INT_32TO64_64C(IW , IPE8(NCMP+1)-1_8, IW8 ) CALL MUMPS_COPY_INT_32TO64 (FRERE, NCMP , FRERE8) CALL MUMPS_COPY_INT_32TO64 (OPTIONS_METIS, LOPTIONS_METIS, & OPTIONS_METIS8) CALL METIS_NODEND( int(NCMP,8), IPE8, IW8, FRERE8, & OPTIONS_METIS8, IKEEP28, IKEEP18 ) CALL MUMPS_COPY_INT_64TO32(IKEEP18, NCMP, IKEEP1) CALL MUMPS_COPY_INT_64TO32(IKEEP28, NCMP, IKEEP2) DEALLOCATE(IW8, FRERE8, IKEEP18, IKEEP28) 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) IMPLICIT NONE INTEGER, INTENT(IN) :: NCMP INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(INOUT) :: IPE8(NCMP+1) INTEGER, INTENT(OUT) :: PARENT(NCMP) INTEGER(8), INTENT(IN) :: IWFR8 INTEGER :: PTRAR(NCMP) INTEGER :: IW(LIW8) INTEGER :: IWL1(NCMP) INTEGER, INTENT(OUT) :: IKEEP1(NCMP) INTEGER, INTENT(OUT) :: IKEEP2(NCMP) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK 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_COPY_INT_64TO32(IPE8,NCMP+1,IPE) CALL MUMPS_SCOTCH( NCMP, int(LIW8), IPE, int(IWFR8), & PTRAR, IW, IWL1, IKEEP1, & IKEEP2, NCMPA ) 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) IMPLICIT NONE INTEGER, INTENT(IN) :: NCMP INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(INOUT) :: IPE8(NCMP+1) INTEGER, INTENT(OUT) :: PARENT(NCMP) INTEGER(8), INTENT(IN) :: IWFR8 INTEGER :: PTRAR(NCMP) INTEGER :: IW(LIW8) INTEGER :: IWL1(NCMP) INTEGER, INTENT(OUT) :: IKEEP1(NCMP) INTEGER, INTENT(OUT) :: IKEEP2(NCMP) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: KEEP10 INTEGER(8), DIMENSION(:), ALLOCATABLE :: & PTRAR8, IW8, IWL18, IKEEP18, & IKEEP28 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL MUMPS_SCOTCH_64( NCMP, LIW8, & IPE8, & IWFR8, & PTRAR, IW, IWL1, IKEEP1, & IKEEP2, NCMPA ) PARENT(1:NCMP) = int(IPE8(1:NCMP)) ELSE ALLOCATE( IW8(LIW8), & 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+LIW8 ) & , INFO(2) ) RETURN ENDIF CALL MUMPS_COPY_INT_32TO64_64C(IW,LIW8,IW8) CALL MUMPS_COPY_INT_32TO64(PTRAR,NCMP,PTRAR8) CALL MUMPS_SCOTCH_64( int(NCMP,8), LIW8, & IPE8, & IWFR8, & PTRAR8, IW8, IWL18, IKEEP1, & IKEEP2, NCMPA ) 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_COPY_INT_64TO32(IWL18,NCMP,IWL1) CALL MUMPS_COPY_INT_64TO32(IKEEP18,NCMP,IKEEP1) CALL MUMPS_COPY_INT_64TO32(IKEEP28,NCMP,IKEEP2) CALL MUMPS_COPY_INT_64TO32(IPE8,NCMP,PARENT) 500 CONTINUE DEALLOCATE(IW8, PTRAR8, IWL18, IKEEP18, IKEEP28) ENDIF 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_COPY_INT_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_COPY_INT_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_COPY_INT_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_COPY_INT_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 CALL MUMPS_COPY_INT_32TO64_64C(JCNHALO, & IPTRHALO(NHALO+1)-1, JCNHALO_I8) NHALO_I8 = int(NHALO,8) NBGROUPS_I8 = int(NBGROUPS,8) CALL MUMPS_METIS_KWAY_64(NHALO_I8, IPTRHALO(1), & JCNHALO_I8(1), NBGROUPS_I8, PARTS_I8(1)) CALL MUMPS_COPY_INT_64TO32(PARTS_I8, & size(PARTS), PARTS) DEALLOCATE(JCNHALO_I8, PARTS_I8) RETURN END SUBROUTINE MUMPS_METIS_KWAY_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(NVTX+1) INTEGER, INTENT(OUT) :: NV(NVTX) INTEGER :: IW(NEDGES8) 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_COPY_INT_64TO32(XADJ8, NVTX+1, XADJ) CALL MUMPS_PORDF( NVTX, int(NEDGES8), XADJ, IW, & 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 ) 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(NVTX+1) INTEGER, INTENT(OUT) :: NV(NVTX) INTEGER, INTENT(IN) :: IW(NEDGES8) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 INTEGER(8), DIMENSION(:), ALLOCATABLE :: IW8, NV8 INTEGER :: I, allocok IF (KEEP10.EQ.1) THEN CALL MUMPS_PORDF( int(NVTX,8), NEDGES8, XADJ8, IW, & NV, NCMPA ) DO I=1, NVTX PARENT(I)=int(XADJ8(I)) ENDDO ELSE ALLOCATE(IW8(NEDGES8), NV8(NVTX), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(NEDGES8+int(NVTX,8),INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORD_MIXEDto64" RETURN ENDIF CALL MUMPS_COPY_INT_32TO64_64C(IW, NEDGES8, IW8) CALL MUMPS_PORDF( int(NVTX,8), NEDGES8, XADJ8, IW8, & NV8, NCMPA ) DO I= 1, NVTX PARENT(I) = int(XADJ8(I)) ENDDO DO I= 1, NVTX NV(I) = int(NV8(I)) ENDDO DEALLOCATE(IW8,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(N) INTEGER(8) :: XADJ8(N+1) INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER :: IW(NEDGES8) 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(N+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_COPY_INT_64TO32(XADJ8,N+1,XADJ) CALL MUMPS_PORDF_WND( NVTX, int(NEDGES8), & XADJ, IW, & 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 ) 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(N+1) INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER :: IW(NEDGES8) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 INTEGER(8), DIMENSION(:), ALLOCATABLE :: IW8, NV8 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL MUMPS_PORDF_WND( int(NVTX,8), NEDGES8, & XADJ8, IW, & NV, NCMPA, int(N,8) ) CALL MUMPS_COPY_INT_64TO32(XADJ8, NVTX, PARENT) ELSE ALLOCATE(IW8(NEDGES8), NV8(N), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(NEDGES8+int(NVTX,8),INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORD_MIXEDto64" RETURN ENDIF CALL MUMPS_COPY_INT_32TO64_64C(IW, NEDGES8, IW8) CALL MUMPS_COPY_INT_32TO64(NV, NVTX, NV8) CALL MUMPS_PORDF_WND( int(NVTX,8), NEDGES8, & XADJ8, IW8, & NV8, NCMPA, int(N,8) ) CALL MUMPS_COPY_INT_64TO32(XADJ8, NVTX, PARENT) CALL MUMPS_COPY_INT_64TO32(NV8, NVTX, NV) DEALLOCATE(IW8, 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.1.2/src/bcast_errors.F0000664000175000017500000000173013164366241016321 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE MUMPS_PROPINFO( ICNTL, INFO, COMM, ID ) INTEGER ICNTL(40), INFO(40), 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.1.2/src/zmumps_f77.F0000664000175000017500000003277613164366265015673 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, 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, & 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, & IRHS_SPARSE, IRHS_SPARSEhere, & IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, & NZ_RHS, LSOL_loc & , & SCHUR_MLOC, & SCHUR_NLOC, & SCHUR_LLD, & MBLOCK, & NBLOCK, & NPROW, & NPCOL, & & OOC_TMPDIR, & OOC_PREFIX, & WRITE_PROBLEM, & TMPDIRLEN, & PREFIXLEN, & WRITE_PROBLEMLEN & & ) 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 JOB, SYM, PAR, COMM_F77, N, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(40), INFO(40), INFOG(40), 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(*), ISOL_loc(*) 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(*) 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 IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, PERM_INhere, WK_USERhere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, IRHS_PTRhere, IRHS_SPARSEhere, ISOL_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 A_ELT_SIZE, I, Np, IERR INTEGER(8) :: 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 mumps_par_array(INSTANCE_NUMBER)%PTR%KEEP(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%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:40)=ICNTL(1:40) 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%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_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 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:A_ELT_SIZE) END IF 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:NRHS*LRHS) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:NRHS*LREDRHS) 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:LSOL_loc*NRHS) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_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 CALL ZMUMPS( mumps_par ) INFO(1:40)=mumps_par%INFO(1:40) INFOG(1:40)=mumps_par%INFOG(1:40) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:40) = mumps_par%ICNTL(1:40) 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) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N 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 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.1.2/src/mumps_scotch_int.c0000664000175000017500000000130613164366240017242 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/src/zfac_process_root2slave.F0000664000175000017500000002614213164366265020504 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE ZMUMPS_LOAD USE ZMUMPS_OOC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ), 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) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) 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 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)), & SLAVEF ) ) 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 (KEEP(60) .NE. 0) THEN IF (root%yes) THEN IF ( NEW_LOCAL_M .NE. root%SCHUR_MLOC .OR. & NEW_LOCAL_N .NE. root%SCHUR_NLOC ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_PROCESS_ROOT2SLAVE" CALL MUMPS_ABORT() ENDIF ENDIF PTLUST(STEP(IROOT)) = -4444 PTRFAC(STEP(IROOT)) = -4445_8 PTRIST(STEP(IROOT)) = 0 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 ) 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)) 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 ENDIF GOTO 100 ENDIF 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) 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) GOTO 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 ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB2 compress root2slave: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 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(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQA KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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)) 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 )) .LE. 0 ) THEN PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 IF (LREQA.GT.0_8) A(PTRAST(STEP(IROOT)): & PTRAST(STEP(IROOT))+LREQA-1_8) = ZERO 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(.FALSE., MYID, N, IPOS_SON, & PAMASTER(STEP(IROOT)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 END IF END IF IF (NEW_LOCAL_M.GT.OLD_LOCAL_M) 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 100 CONTINUE NBPROCFILS(STEP(IROOT))=NBPROCFILS(STEP(IROOT)) + TOT_CONT_TO_RECV #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN #endif 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(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.1.2/src/mumps_scotch.c0000664000175000017500000000252013164366240016367 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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 ) { *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); } #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.1.2/src/cfac_type3_symmetrize.F0000664000175000017500000001352313164366264020151 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/sana_driver.F0000664000175000017500000050107013164366266016137 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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, FILS, FRERE, NFSIZ INTEGER NE, NA INTEGER I, allocok INTEGER MAXIS1_CHECK 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, SBUF_REC, 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 C to store the size of the sequencial peak of stack C (or an estimation for not calling REORDER_TREE_N ) REAL PEAK C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, DIMENSION(:) :: PAR2_NODES 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_STAT INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED 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 INTEGER, POINTER, DIMENSION(:) :: WORK1PTR, WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR ! Used because of multithreaded SIM_NP_ INTEGER :: locMYID, locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER(kind=8) :: N8, NZ8, LIW8 INTEGER :: LIW_ELT 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 KEEP8(24) = 0_8 ! reinitialize last used size of WK_USER KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) 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 ---------------------------------------- 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 (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) 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 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) C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ) 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 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ---------------------------------------------- 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 ( associated(id%MEM_DIST) ) deallocate( id%MEM_DIST ) 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 ) RETURN 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 ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( KEEP(54) .eq. 3 ) THEN C ----------------------------------------------- C Collect on the host -- if matrix is distributed C at analysis -- all integer information. C ----------------------------------------------- CALL SMUMPS_GATHER_MATRIX(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN END IF C ************************************************ C BEGINNING OF MASTER CODE FOR SEQUENTIAL ANALYSIS C ************************************************ 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. Done before 1234 label in order to avoid C two allocations of size 1 and a memory leak in case C there are two passes (see 1234 label below and C "GOTO 1234" statement) 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 in Schur ' CALL MUMPS_ABORT() END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF 1234 CONTINUE IF ( ( (KEEP(23) .NE. 0) .AND. & ( (KEEP(23).NE.7) .OR. KEEP(50).EQ. 2 ) ) & .OR. & ( associated(id%A) .AND. KEEP(52) .EQ. 77 .AND. & (KEEP(50).EQ.2)) & .OR. & KEEP(52) .EQ. -2 ) THEN C MAXIMUM TRANSVERSAL ALGORITHM called on original matrix. C KEEP(23) = 7 means that automatic choice C of max trans value will be done during Analysis. C We compute a permutation of the original matrix to have zero free diagonal C the col. Permutation is held in IS1(1, ...,N). C Max-trans (SMUMPS_ANA_O) is not used for element entry. IF (.not.associated(id%A)) THEN C -- If maxtrans is required and A not allocated then reset C -- it to structural based maxtrans. IF (KEEP(23).GT.2) KEEP(23) = 1 ENDIF CALL SMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%IS1(1), id, & ICNTL(1), INFO(1)) IF (INFO(1) .LT. 0) THEN C ----------- C Fatal error C ----------- C Permutation was not computed; reset keep(23) KEEP(23) = 0 GOTO 10 END IF END IF C END OF MAX-TRANS ON THE MASTER C C ********************************************************** C C BEGINNING OF ANALYSIS, STILL ON THE MASTER C C Set up subdivisions of arrays for analysis C C ------------------------------------------------------ C Define the size of a working array C that will be used as workspace SMUMPS_ANA_F. 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 N8=int(id%N,8) IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=int(id%KEEP8(28),8) IF ( KEEP(256) .EQ. 1 ) THEN ! KEEP(256) <-- ICNTL(7) LIW8 = 2_8 * NZ8 + N8 + 1_8 ELSE LIW8 = 2_8 * NZ8 + N8 + 1_8 ENDIF 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*N8) LIW8 = 3_8*N8 ELSE IF (LIW_ELT.LT.3*id%N) LIW_ELT = 3*id%N ENDIF IF (KEEP(23) .NE. 0) THEN IKEEP = id%N + 1 ELSE IKEEP = 1 END IF NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N MAXIS1_CHECK = NFSIZ + id%N - 1 C C ANALYSIS PHASE C Some workspace of SMUMPS_ANA_F can be reused in subsequent phases. C IS(IKEEP) OF LENGTH 3*N C IS(NFSIZ) OF LENGTH N holds the frontal matrix sizes C IS(FILS) and IS(FRERE) OF LENGTH N holds the assembly tree C IF ( KEEP(256) .EQ. 1 ) THEN C Note that id%PERM_IN has been checked before. DO I = 1, id%N id%IS1( IKEEP + I - 1 ) = id%PERM_IN( I ) END DO 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 CALL SMUMPS_ANA_F(id%N, id%KEEP8(28), & id%IRN(1), id%JCN(1), & LIW8, id%IS1(IKEEP), & KEEP(256), id%IS1(NFSIZ), & id%IS1(FILS), id%IS1(FRERE), & id%LISTVAR_SCHUR(1), SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1),id%NSLAVES, & id%IS1(1),id) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max trans KEEP(23) = -KEEP(23) IF (.NOT. associated(id%A)) KEEP(23) = 1 GOTO 1234 ENDIF INFOG(7) = KEEP(256) 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, & id%IS1(IKEEP), & KEEP(256), id%IS1(NFSIZ), id%IS1(FILS), & id%IS1(FRERE), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1)) 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 ) 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) C Check error during SMUMPS_ANA_F OR SMUMPS_ANA_F_ELT IF ( INFO(1) .LT. 0 ) THEN GO TO 10 ENDIF ENDIF ELSE C Parallel analysis IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N IF (id%MYID .EQ. MASTER) THEN C this correspond to the old PTRAR part of IS1 C WORK2PTR => id%IS1(PTRAR : PTRAR + 4*id%N-1) ALLOCATE(WORK2PTR(4*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(WORK1PTR(3*id%N),WORK2PTR(4*id%N), stat=IERR ) ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN INFO( 2 ) = 4*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 ) RETURN IF(id%MYID .EQ. MASTER) THEN WORK1PTR => id%IS1(IKEEP : IKEEP + 3*id%N-1) NFSIZPTR => id%IS1(NFSIZ : NFSIZ + id%N-1) FILSPTR => id%IS1(FILS : FILS + id%N-1) FREREPTR => id%IS1(FRERE : FRERE + id%N-1) END IF CALL SMUMPS_ANA_F_PAR(id, & WORK1PTR, & WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR) DEALLOCATE(WORK2PTR) IF(id%MYID .EQ. 0) THEN NULLIFY(WORK1PTR, NFSIZPTR) NULLIFY(FILSPTR, FREREPTR) ELSE DEALLOCATE(WORK1PTR) END IF KEEP(28) = INFOG(6) END IF 10 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN 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(id%N, id%IS1(FILS), id%IS1(FRERE), & id%IS1(NE), id%IS1(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 id%KEEP(20)=0 id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C id%PROCNODE = 0 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 CALL SMUMPS_SET_PROCNODE(id%KEEP(38), id%PROCNODE(1), & 1+2*id%NSLAVES, id%IS1(FILS),id%N) 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 => id%IS1(IKEEP:IKEEP+id%N-1) C Map nodes and assign candidates for dynamic scheduling CALL SMUMPS_DIST_AVOID_COPIES(id%N,id%NSLAVES,ICNTL(1), & INFOG(1), & id%IS1(NE), & id%IS1(NFSIZ), & id%IS1(FRERE), & id%IS1(FILS), & KEEP(1),KEEP8(1),id%PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & ) 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(id%N, id%IS1(FILS), & id%IS1(FRERE), id%IS1(NE), & id%IS1(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN 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) ) 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 ) RETURN 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, id%IS1(FRERE), & id%IS1(FILS), & id%IS1(IKEEP+id%N), id%IS1(IKEEP+2*id%N), 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 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 numbers. C This is used later in the initial elemental C matrix distribution at the beginning of the factorisation phase C --------------------------------------- CALL SMUMPS_ELTPROC(id%N, NELT, id%ELTPROC(1),id%NSLAVES, & id%PROCNODE(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, id%N IF ( ( id%IS1(FRERE+INODE-1) .NE. id%N+1 ) .AND. & ( MUMPS_TYPENODE(id%PROCNODE(INODE),id%NSLAVES) & .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 * =============================== * ! blocking factor for multiple RHS for ana_distm KEEP(84) = ICNTL(27) END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. 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 MUMPS_BCAST_I8( id%KEEP8(21), MASTER, & id%MYID, 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 ----------------- C Broadcast LR related keep informations KEEP(483-492) C if includes MPI_BCAST(idKEEP(486) CALL MPI_BCAST( id%KEEP(483), 10, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Save setting (used later during factorization) C to enable BLR KEEP(494) = KEEP(486) 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 C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) 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 CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 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 CALL MUMPS_REALLOC(id%LRGROUPS, id%N, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. IF ( associated( id%UNS_PERM ) ) deallocate(id%UNS_PERM) C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID == MASTER .AND. id%KEEP(23) .NE. 0 ) THEN C This one is only on the master allocate(id%UNS_PERM(id%N),stat=allocok) IF ( allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = id%N IF ( LPOK ) THEN WRITE(LP, 150) 'id%UNS_PERM' END IF GOTO 94 ENDIF C DO I=1,id%N id%UNS_PERM(I) = id%IS1(I) END DO ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN DO I=1,id%N id%FILS(I) = id%IS1(FILS+I-1) ENDDO END IF 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 (id%N.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (id%IS1(NA+id%N-1) .LT.0) THEN NBLEAF = id%N NBROOT = id%N ELSE IF (id%IS1(NA+id%N-2) .LT.0) THEN NBLEAF = id%N-1 NBROOT = id%IS1(NA+id%N-1) ELSE NBLEAF = id%IS1(NA+id%N-2) NBROOT = id%IS1(NA+id%N-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) IF(INFO(1).LT.0) GOTO 96 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 ( id%N == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (id%IS1(NA+id%N-1) < 0) THEN id%NA(LEAF) = - id%IS1(NA+id%N-1)-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO ELSE IF (id%IS1(NA+id%N-2) < 0 ) THEN INODE = - id%IS1(NA+id%N-2) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO END IF END IF 96 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF ( id%MYID .EQ. MASTER ) THEN 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, id%N IF ( id%IS1(FRERE+I-1) .ne. id%N + 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 = id%IS1(FILS+I-1) DO WHILE ( INN .GT. 0 ) id%STEP(INN) = - ISTEP INN = id%IS1(FILS + INN -1) END DO IF (id%IS1(FRERE+I-1) .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' CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ DO I = 1, id%N IF (id%IS1(FRERE+I-1) .NE. id%N+1) THEN id%PROCNODE_STEPS(id%STEP(I)) = id%PROCNODE( I ) id%FRERE_STEPS(id%STEP(I)) = id%IS1(FRERE+I-1) id%NE_STEPS(id%STEP(I)) = id%IS1(NE+I-1) id%ND_STEPS(id%STEP(I)) = id%IS1(NFSIZ+I-1) ENDIF ENDDO C =============================== C Algoritme 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, id%N C -- skip non principal nodes IF ( id%STEP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (id%IS1(FRERE+I-1) .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 = id%IS1(FILS+I-1) DO WHILE ( IFS .GT. 0 ) IFS= id%IS1(FILS + IFS -1) 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 = id%IS1(FRERE+IFS-1) ENDDO END DO C C C Following arrays (PROCNODE and IS1) not used anymore C during analysis DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) DEALLOCATE(id%IS1) NULLIFY(id%IS1) 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. 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%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 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 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%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 C Compute a grouping of variables for LR approximations. C id%SYM_PERM is used as a work array IF(KEEP(486) .EQ. 1) THEN IF ( (KEEP(54).eq.3) .AND. (KEEP(244).eq.2) ) THEN C If the input matrix is distributed and the parallel analysis is C chosen, the graph has to be centralized in order to compute the C clustering. CALL SMUMPS_GATHER_MATRIX(id) END IF IF (KEEP(469).EQ.0) THEN CALL SMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN(1), & id%JCN(1), id%FILS(1), id%FRERE_STEPS(1), & id%DAD_STEPS(1), id%NE_STEPS(1), id%STEP(1), id%NA(1), & id%LNA, id%LRGROUPS(1), & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), id%KEEP(489), & 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), LPOK, LP) ELSE CALL SMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN(1), & id%JCN(1), id%FILS(1), id%FRERE_STEPS(1), & id%DAD_STEPS(1), id%NE_STEPS(1), id%STEP(1), id%NA(1), & id%LNA, id%LRGROUPS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), id%KEEP(489), & 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), LPOK, LP) ENDIF IF ( (KEEP(54).eq.3) .AND. (KEEP(244).eq.2) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above deallocate(id%IRN, id%JCN) NULLIFY(id%IRN) NULLIFY(id%JCN) END IF END IF CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 80 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%INFO(1) ) ELSE ! matches the IF (id%MYID .EQ. MASTER) THEN ... above CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 80 IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2) & .AND. (abs(KEEP(486)).EQ.1)) THEN C If the input matrix is distributed and the parallel analysis is C chosen, the graph has to be centralized in order to compute the C clustering. CALL SMUMPS_GATHER_MATRIX(id) END IF ENDIF C Root principal variable C for scalapack (KEEP(38)) might have been updated C since root variables might have been permuted. C It should thus be redistributed to all procs IF((abs(KEEP(486)) .EQ. 1).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 ) RETURN 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(486).EQ.1) 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_PAR, 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_PAR(id, id%PTRAR(1)) 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 DEALLOCATE( id%IRN ) DEALLOCATE( id%JCN ) 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)) & deallocate(id%DEPTH_FIRST) 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)) * DEALLOCATE(id%DEPTH_FIRST_SEQ) 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)) * DEALLOCATE(id%SBTR_ID) 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)) & deallocate(id%DEPTH_FIRST) 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)) * DEALLOCATE(id%DEPTH_FIRST_SEQ) 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)) * DEALLOCATE(id%SBTR_ID) 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)) & deallocate(id%COST_TRAV) 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)) & deallocate(id%COST_TRAV) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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 ) RETURN 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)) deallocate(id%CANDIDATES) 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 ) RETURN 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 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 ! defined(OLD_LOAD_MECHANISM) 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%NSLAVES) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO #endif 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 ) RETURN C ------------------------------ C Perform again the subdivision of array C IS1, both on the master and on C the slaves. This is done so to C ease the passage to the model C where master will work. C ------------------------------ C IF ( KEEP(23).NE.0 .and. id%MYID .EQ. MASTER ) THEN IKEEP = id%N + 1 ELSE IKEEP = 1 END IF FILS = IKEEP + 3 * id%N NE = IKEEP + 2 * id%N NA = IKEEP + id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N 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 ) RETURN IF ( I_AM_SLAVE ) THEN 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 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 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 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)) ENDIF CALL SMUMPS_ANA_DISTM( locMYID_NODES, id%N, & id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), id%DAD_STEPS(1), & id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, & KEEP8(11), KEEP(26), KEEP(15), & KEEP8(12), ! formerly KEEP(16), & KEEP8(14), ! formerly KEEP(200), & KEEP(224), KEEP(225), & KEEP(27), RINFO(1), & KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, SBUF_RECOLD8, & SBUF_SEND, SBUF_REC, 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(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) + 2* 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) + 2* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) C size of S KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) C size of S KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /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 = max(SBUF_SEND,KEEP(27)) SBUF_REC = max(SBUF_REC ,KEEP(27)) CALL MPI_ALLREDUCE (SBUF_REC, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43)=KEEP(44) ELSE KEEP(43)=SBUF_SEND 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(43) = max(KEEP(43), 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 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 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0E0 END IF 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 -------------------------------------- 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) CALL MUMPS_REDUCEI8( KEEP8(11), KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) C -------------- C Flops estimate C -------------- CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_REAL, MPI_SUM, & id%COMM, IERR) 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) ) 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 IN-CORE MEMORY STATISTICS C ========================= OOC_STAT = KEEP(201) IF (KEEP(201) .NE. -1) OOC_STAT=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_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(2) = TOTAL_BYTES 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_STAT, PERLU_ON, TOTAL_BYTES) IF ( PROK ) THEN WRITE(MP,'(A,I10) ') & ' Estimated space in MBYTES for IC factorization :', & 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 WRITE( MPG,'(A,I16) ') & ' ** Rank of proc needing largest memory in IC facto :', & IRANK WRITE( MPG,'(A,I16) ') & ' ** Estimated corresponding MBYTES for IC facto :', & id%INFOG(16) IF ( KEEP(46) .eq. 0 ) THEN C Host not working WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,(id%INFOG(17)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,id%INFOG(17)/id%NSLAVES END IF WRITE(MPG,'(A,I16) ') & ' ** TOTAL space in MBYTES for IC factorization :' & ,id%INFOG(17) END IF C ========================================= C NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS C (except when OOC_STAT is equal to -1 in C which case IC and OOC statistics are C identical) C ========================================= OOC_STAT = KEEP(201) #if defined(OLD_OOC_NOPANEL) IF (OOC_STAT .NE. -1) OOC_STAT=2 #else IF (OOC_STAT .NE. -1) OOC_STAT=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_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(3) = TOTAL_BYTES 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_STAT, PERLU_ON, TOTAL_BYTES) id%INFO(17) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I16) ') & ' ** Rank of proc needing largest memory for OOC facto :', & IRANK WRITE( MPG,'(A,I16) ') & ' ** Estimated corresponding MBYTES for OOC facto :', & id%INFOG(26) IF ( KEEP(46) .eq. 0 ) THEN C Host not working WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,(id%INFOG(27)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,id%INFOG(27)/id%NSLAVES END IF WRITE(MPG,'(A,I16) ') & ' ** TOTAL space in MBYTES for OOC factorization :' & ,id%INFOG(27) END IF c #endif 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)) & deallocate( id%MAPPING) 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 CALL SMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & id%IRN(1),id%JCN(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 ) RETURN KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 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 Fwd in facto 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 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 IF ( PROKG ) THEN WRITE(MPG, '(A)') & ' Resetting candidate strategy to 0 because NSLAVES=1' WRITE(MPG, '(A)') ' ' END IF 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 IF ( PROKG ) THEN WRITE(MPG, '(A)') & ' Resetting candidate strategy to 8 ' WRITE(MPG, '(A)') ' ' END IF 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 ---------------------------- 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 kept for backward compatibility.' 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 * * Graph modification prior to ordering (id%ICNTL(12) option) * id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) * id%KEEP(95) = id%ICNTL(12) 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) = 0 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 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) = 7 C still forbid max trans for LLT IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not compatible with LLT 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 compatible with LLT 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).NE.0) 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 id%KEEP(95) = 1 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans 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)') & ' ** Max-trans not allowed because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN C Only Ruiz & Bora scaling available for dist format C (Work supported by ANR-SOLSTICE (ANR-06-CIS6-010)) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed (matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(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)') & ' ** Max-trans not allowed for element matrix' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling not allowed at analysis for element matrix' 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(39).NE.1 .and. id%ICNTL(39).NE.2) 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(39) 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(16) (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 -- Block low rank input parameter checking id%KEEP(486) = id%ICNTL(35) C KEEP(486)!=0,1 => KEEP(486)=0 IF (id%KEEP(486).NE.1) id%KEEP(486) = 0 IF(id%KEEP(486).NE.0) THEN C tests that may switch off BLR C C LR is incompatible with elemental matrices IF (id%KEEP(55).NE.0) THEN IF (PROK) WRITE(MP,*) & "WARNING: BLR feature currently incompatible " & ,"with elemental matrices" C Switch off BLR id%KEEP(486)=0 ENDIF C C LR incompatible with forward in facto in facto IF (id%KEEP(252).NE.0) THEN IF (PROK) WRITE(MP,*) & "WARNING: BLR feature currently incompatible " & ,"with forward during factorization" C Switch off BLR id%KEEP(486)=0 ENDIF IF((id%KEEP(492).EQ.0)) THEN id%KEEP(486)=0 ENDIF ENDIF C IF(id%KEEP(486).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(470)=0 or 1 IF ((id%KEEP(470).NE.0).AND.(id%KEEP(470).NE.1)) THEN id%KEEP(470)=1 ENDIF 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(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(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=4 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 IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 write(*,*) 'KEEP(480) = 0 => Resetting KEEP(474) to 0' ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 write(*,*) 'KEEP(480) < 4 => Resetting KEEP(478) to 0' ENDIF C In LUA strategy KEEP(480)>=5, we exploit LRTRSM to further C reduce the flops. It requires KEEP(475)>=2. 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 IF (id%KEEP(474).EQ.3) THEN write(*,*) 'KEEP(480) = ',id%KEEP(480), & ' and KEEP(474) = 3 ', & 'requires KEEP(475) >= 2, but it is = ', id%KEEP(475) ELSE write(*,*) 'KEEP(480) = ',id%KEEP(480), & 'requires KEEP(475) >= 2, but it is = ', id%KEEP(475) ENDIF 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 C id%KEEP(481)=0,1,2 IF ((id%KEEP(481).GT.2).OR.(id%KEEP(481).LT.0)) THEN id%KEEP(481)=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 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(485)>0 IF((id%KEEP(485).LT.0)) THEN id%KEEP(485)= 1 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(489)=0 or 1 IF ((id%KEEP(489).NE.0).AND.(id%KEEP(489).NE.1)) THEN id%KEEP(489)=0 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 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' TYPE(SMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: MASTER, IERR, INDX INTEGER :: STATUS(MPI_STATUS_SIZE) 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 PARAMETER( MASTER = 0 ) 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 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 GOTO 13 ENDIF 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)/20_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, opens a file and dumps the matrix and/or C the right hand side. This subroutine calls C SMUMPS_DUMP_MATRIX and SMUMPS_DUMP_RHS. C The routine should be called on all processors. C INCLUDE 'mpif.h' C Arguments C ========= TYPE(SMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED INTEGER :: MM_WRITE INTEGER :: MM_WRITE_CHECK CHARACTER(LEN=20) :: MM_IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER 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) 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 (id%WRITE_PROBLEM(1:20) .NE. "NAME_NOT_INITIALIZED")THEN 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 CLOSE(IUNIT) ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN C ===================== C Matrix is distributed C ===================== IF (id%WRITE_PROBLEM(1:20) .EQ. "NAME_NOT_INITIALIZED" & .OR. .NOT. I_AM_SLAVE )THEN MM_WRITE = 0 ELSE MM_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(MM_WRITE, MM_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 (MM_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(MM_IDSTR,'(I9)') id%MYID_NODES OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(MM_IDSTR))) CALL SMUMPS_DUMP_MATRIX(id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL ) ! Elemental or not CLOSE(IUNIT) ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. & id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED")THEN OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL SMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE SMUMPS_DUMP_PROBLEM SUBROUTINE SMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL ) 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 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)) 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)) 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)) 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)) 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" WRITE(IUNIT,*) id%A_ELT(:) 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, K, LD_RHS 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_RHS = id%N ELSE LD_RHS = id%LRHS ENDIF DO J = 1, id%NRHS DO I = 1, id%N K=(J-1)*LD_RHS+I WRITE(IUNIT,*) id%RHS(K) 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 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, K489, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & LPOK, LP) USE SMUMPS_ANA_LR C This routine is meant to compute a grouping of the variables in C all the separators. This grouping defines the blocks that will C be compressed by means of low-rank approximations. Because the C principal variables of all separators will be changed, it is C necessary to update the arrays FILS, FRERE_STEPS, DAD_STEPS, STEP, C NA. C C N - the size of the input matrix C NZ8 - the nnz in the input matrix C NSTEPS - the numbers of nodes in the tree C IRN - the row indices of the input matrix C JCN - the col indices of the input matrix C FILS - the fils array of size N. This array will be C modified on output according to the new relative C order computed for the variables in the separators C FRERE_STEPS - the FRERE_STEPS array. Modified on output (as for FILS) C DAD_STEPS - the DAD_STEPS array. Modified on output (as for FILS) C NE_STEPS - the NE_STEPS array. Modified on output (as for FILS) C STEP - the STEP array. Modified on output (as for FILS) C NA - the NA array. Modified on output (as for FILS) C LNA - The length of the NA array C LRGROUPS - the array mapping variables onto groups. C LRGROUPS(i)=k means that variable i belongs to C group k C SYM - the type of matrix (KEEP(50)) C ICNTL - the ICNTL array C HALO_DEPTH - the depth of the halo around the separator subgraph C GROUP_SIZE - the size of variables groups in the separators C K489 - BLR strategy (=3 compress CB) C SEP_SIZE - the minimum size of a separator to be treated with C low-rank approximations C has to be used for computing the clustering C IFLAG - < 0 in case of error C IERROR - complementary information in case of error C e- =0 upon succesful return, > 0 otherwise C C LP, LPOK to control error printing C C C This routine traverses the tree in a DFS fashion using a pool C where nodes are pushed as soon as their parent is treated. Nodes C are pushed in the pool in the same order as FRERE_STEPS and, since C nodes are popped from the head of this pool, this means that C siblings are treated in reverse order. This makes it easier to C modify FRERE_STEPS because it will be always updated wrt a node C which has already been treated. The update of NA relies on the C assumption that a DFS touches the leaves in the same order as they C appear in NA (in reverse order in this case for what said above). C The roots are therefore pushed in the pool in reverse order. C An array of order NSTEPS is allocated to store the principal C variables of all the nodes that have been treated. This array C could be spared at the price of expensive pointer chasing inside C FILS. IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE, K489 INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: IRN(NZ8), JCN(NZ8), NE_STEPS(NSTEPS), & ICNTL(40) INTEGER, INTENT(INOUT) :: FILS(N), FRERE_STEPS(NSTEPS), STEP(N), & NA(LNA), DAD_STEPS(NSTEPS), LRGROUPS(N) 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 INTERFACE 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) INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) END SUBROUTINE END INTERFACE C Check for Schur (// or sequential) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF C If automatic choice of partitioning tool is required, then metis C comes first, if available; otherwise scotch; otherwise C permuted matrix is simply split. C If a particular tool C is required, we check for its availability, otherwise we revert to C automatic choice 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 C The global number of groups computed NBGROUPS = 0 C Build the unsymmetrized graph of the input matrix. The LGROUPS C array will be immediately allocated and used as a scratchpad C memory for SMUMPS_ANA_GNEW IF (K265.EQ.-1) THEN C unsymmetric matrix, structurally symmetric LW = NZ8 ELSE C worst case need to double matrix size 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, IWFR, NRORM, NIORM, IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265) IF (allocated(IQ)) DEALLOCATE(IQ) C LRGROUPS has been used as a workspace in ana_gnew so we should C reinitialize it to -1 to be sure that a variable which is in no C group (ie in no grouped separator) can be identified correctly LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS C Push the roots in the pool in reverse order C DO I = 1, NROOTS C POOL(I) = NA(2+NLEAVES+NROOTS-I+1) C END DO C BUGFIX 18/11/2016 C Because the elements from the pool are taken in reverse order and the C NA is also updated in reverse order in MUMPS_UPD_TREE, this was C actually false! The roots should be pushed in the pool in natural C order. Cf email "Bugs L0" 18/11/2016. DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS C arrays of size N used to computed each halo 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 C Loop until the pool is empty DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) C This variable tells whether node is the oldest son of its parent. C In this case fils(fils(...fils(dad_steps(node)))) is updated FIRST = POOL(PP) .LT. 0 C Go down until the last variable in this front and make a list of C the fully assembled variables in it inside the work array NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO C Do the grouping. Upon return, work contains the variable in the C new order and NBGROUPS has been increased by the number of groups C computed in the current separator C Grouping is done if the current node is large enough, i.e. bigger C than the cluster size GROUP_SIZE. The grouping must be done C even if NV is smaller than SEP_SIZE: in that case, we give to all C of its variables a negative group number so that we have grouping C for all the variables which is needed in case we have for example C a chain like (say we do low-rank if nass > 8) father (nass=5) son (nass=10) C in this case we need a clustering of the CB of 'son' which may be partly C inherited from the clustering of the FS of 'father' so this latter C clustering should be done even if 'father' is not eligible for LR. Not C likely to happen often with metis-like ordering but it should be done C for robustness. C Moreover, as a front can be chosen for LR during facto even if the C separator was too small for proper grouping ( this occurs with delayed C pivots), we need the negative sign to avoid trying to do a LR facto in C such a case. 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 C Disable permutation/clustering. Leaves the ordering unchanged C and simply pack variables into groups of size SIZE_GROUP. C NB: this doesn't care about FS/CB, or about slaves, etc, so C it is useful only for a NIV1 root basically. DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+I/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + NV/GROUP_SIZE2 + 1 ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS(1), 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 C If NV is smaller than GROUP_SIZE then all variables are in a C single group, which value is negative if NV is also smaller C than SEP_SIZE. 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 C be careful, both val and -val are not present in the LRGROUPS array ENDIF C Update the tree according to the newly computed order CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS(1), FRERE_STEPS(1), STEP(1), DAD_STEPS(1), & NE_STEPS(1), NA(1), LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN C Restore potentially modified root number IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF C Put all the children of node in the pool. The first child is C always pushed with a negative index in order to establish when to C update the FILS array for the last variable in its parent (through C the FIRST variable above) 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) C RETURN END SUBROUTINE SMUMPS_LR_GROUPING SUBROUTINE SMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, K489, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, LPOK, LP) USE SMUMPS_ANA_LR C This routine is meant to compute a grouping of the variables in C all the separators. This grouping defines the blocks that will C be compressed by means of low-rank approximations. Because the C principal variables of all separators will be changed, it is C necessary to update the arrays FILS, FRERE_STEPS, DAD_STEPS, STEP, C NA. C C N - the size of the input matrix C NZ8 - the nnz in the input matrix C NSTEPS - the numbers of nodes in the tree C IRN - the row indices of the input matrix C JCN - the col indices of the input matrix C FILS - the fils array of size N. This array will be C modified on output according to the new relative C order computed for the variables in the separators C FRERE_STEPS - the FRERE_STEPS array. Modified on output (as for FILS) C DAD_STEPS - the DAD_STEPS array. Modified on output (as for FILS) C NE_STEPS - the NE_STEPS array. Modified on output (as for FILS) C STEP - the STEP array. Modified on output (as for FILS) C NA - the NA array. Modified on output (as for FILS) C LNA - The length of the NA array C LRGROUPS - the array mapping variables onto groups. C LRGROUPS(i)=k means that variable i belongs to C group k C SYM - the type of matrix (KEEP(50)) C ICNTL - the ICNTL array C HALO_DEPTH - the depth of the halo around the separator subgraph C GROUP_SIZE - the size of variables groups in the separators C SEP_SIZE - the minimum size of a separator to be treated with C low-rank approximations C has to be used for computing the clustering C IFLAG - < 0 in case of error C IERROR - complementary information in case of error C e- =0 upon succesful return, > 0 otherwise C C LP, LPOK to control error printing C C C This routine traverses the tree in a DFS fashion using a pool C where nodes are pushed as soon as their parent is treated. Nodes C are pushed in the pool in the same order as FRERE_STEPS and, since C nodes are popped from the head of this pool, this means that C siblings are treated in reverse order. This makes it easier to C modify FRERE_STEPS because it will be always updated wrt a node C which has already been treated. The update of NA relies on the C assumption that a DFS touches the leaves in the same order as they C appear in NA (in reverse order in this case for what said above). C The roots are therefore pushed in the pool in reverse order. C An array of order NSTEPS is allocated to store the principal C variables of all the nodes that have been treated. This array C could be spared at the price of expensive pointer chasing inside C FILS. IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE, K489 INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: IRN(NZ8), JCN(NZ8), NE_STEPS(NSTEPS), & ICNTL(40) INTEGER, INTENT(INOUT) :: FILS(N), FRERE_STEPS(NSTEPS), STEP(N), & NA(LNA), DAD_STEPS(NSTEPS), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, TARGET, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, POINTER, DIMENSION (:) :: TRACE_PTR, WORKH_PTR, & GEN2HALO_PTR INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR INTERFACE 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) INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) END SUBROUTINE END INTERFACE C Check for Schur (// or sequential) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF C If automatic choice of partitioning tool is required, then metis C comes first, if available; otherwise scotch; otherwise C permuted matrix is simply split. C If a particular tool C is required, we check for its availability, otherwise we revert to C automatic choice 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 C The global number of groups computed NBGROUPS = 0 C Build the unsymmetrized graph of the input matrix. The LGROUPS C array will be immediately allocated and used as a scratchpad C memory for SMUMPS_ANA_GNEW 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, IWFR, NRORM, NIORM, IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265) IF (allocated(IQ)) DEALLOCATE(IQ) C LRGROUPS has been used as a workspace in ana_gnew so we should C reinitialize it to -1 to be sure that a variable which is in no C group (ie in no grouped separator) can be identified correctly LRGROUPS = -1 IF (K469.NE.2) THEN C K469=1 or 3: arrays of size N shared by all threads 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 !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, !$OMP& WORKH_PTR, TRACE_PTR, GEN2HALO_PTR) IF(K469.GT.1) ALLOCATE(WORK(MAXFRONT), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT IFLAG = -7 IERROR = MAXFRONT GOTO 500 ENDIF IF (K469.EQ.2) THEN C K469=2: arrays of size N allocated on each thread ALLOCATE(TRACE_PTR(N), WORKH_PTR(N), GEN2HALO_PTR(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 500 ENDIF ELSE TRACE_PTR => TRACE WORKH_PTR => WORKH GEN2HALO_PTR => GEN2HALO ENDIF IF (K469.EQ.2) THEN TRACE_PTR = 0 ELSE !$OMP SINGLE TRACE_PTR = 0 !$OMP END SINGLE ENDIF C I) Parcours parallele en N pour initialiser PVS PVSCHANGED = .FALSE. !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO C II) Parcours parallele en NSTEPS pour faire le grouping avec C PVS, STEP et FILS (sauf derniere variable) qui sont mis a jour !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) C Construire VLIST a partir de FILS(PV) C Go down until the last variable in this front and make a list of C the fully assembled variables in it inside the work array NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO C Appel a SEP_GROUPING sur VLIST: la variable principale de NODE C change et devient PVS(NODE) C Do the grouping. Upon return, work contains the variable in the C new order and NBGROUPS has been increased by the number of groups C computed in the current separator C Grouping is done if the current node is large enough, i.e. bigger C than the cluster size GROUP_SIZE. The grouping must be done C even if NV is smaller than SEP_SIZE: in that case, we give to all C of its variables a negative group number so that we have grouping C for all the variables which is needed in case we have for example C a chain like (say we do low-rank if nass > 8) father (nass=5) son (nass=10) C in this case we need a clustering of the CB of 'son' which may be partly C inherited from the clustering of the FS of 'father' so this latter C clustering should be done even if 'father' is not eligible for LR. Not C likely to happen often with metis-like ordering but it should be done C for robustness. C Moreover, as a front can be chosen for LR during facto even if the C separator was too small for proper grouping ( this occurs with delayed C pivots), we need the negative sign to avoid trying to do a LR facto in C such a case. 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 C C Disable permutation/clustering. Leaves the ordering unchanged C and simply pack variables into groups of size SIZE_GROUP. C NB: this doesn't care about FS/CB, or about slaves, etc, so C it is useful only for a NIV1 root basically. !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+I/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + NV/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS(1), NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PTR, WORKH_PTR, & NODE, GEN2HALO_PTR, K482_LOC, K472, K469, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) CYCLE C Maj de PVS PVS(NODE) = WORK(1) PVSCHANGED = .TRUE. C Maj de STEP 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 C Maj de FILS DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN C La derniere variable de FILS memorise l'ancienne C variable principale pointee FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE C If NV is smaller than GROUP_SIZE then all variables are in a C single group, which value is negative if NV is also smaller C than SEP_SIZE. !$OMP CRITICAL(lrgrouping_cri) 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 !$OMP END CRITICAL(lrgrouping_cri) ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 C <<<< Synchro >>>> C A ce stade tous les noeuds ont ete traites et PVS, STEP et FILS (sauf derniere variable) C sont a jour C On economise les maj suivantes si inutiles IF (.NOT.PVSCHANGED) GOTO 500 C III) Maj de DAD_STEPS, FRERE_STEPS, NA, et derniere variable de chaque noeud de FILS !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN C Node has a younger brother, update frere_steps(node) FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN C node is the youngest brother, update frere_steps(node) to make C it point to the father 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.EQ.2) THEN DEALLOCATE(TRACE_PTR) DEALLOCATE(WORKH_PTR) DEALLOCATE(GEN2HALO_PTR) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469.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) C RETURN END SUBROUTINE SMUMPS_LR_GROUPING_NEW C SUBROUTINE SEP_GROUPING(NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, C & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH) C IMPLICIT NONE C INTEGER :: NV, N, NZ, LW, NBGROUPS, GROUP_SIZE, HALO_DEPTH C INTEGER :: VLIST(NV), LRGROUPS(N), IW(LW), IPE(N+1), LEN(N) C C INTEGER :: TMP, I C CC Just invert the list C DO I=1, NV/2 C TMP = VLIST(I) C VLIST(I) = VLIST(NV-I+1) C VLIST(NV-I+1) = TMP C END DO C C RETURN C END SUBROUTINE SEP_GROUPING MUMPS_5.1.2/src/dfac_process_contrib_type2.F0000664000175000017500000003411113164366263021132 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ), FILS( N ) 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 'mumps_headers.h' 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 #if ! defined(NO_XXNBPR) INTEGER :: INBPROCFILS_SON #endif 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 ) MASTER = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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) 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 ) CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN 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 ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress DMUMPS_PROCESS_CONTRIB_TYPE2' WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR( LREQA - LRLUS, IERROR ) CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END IF END IF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQA KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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 NBPROCFILS(STEP(INODE))=NBPROCFILS(STEP(INODE))-NBROW #if ! defined(NO_XXNBPR) IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW #endif 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 ) 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 ) 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 CALL DMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ELSE 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 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 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - DECR NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB #if ! defined(NO_XXNBPR) 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 #endif #if ! defined(NO_XXNBPR) IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN #endif 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_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF #if ! defined(NO_XXNBPR) IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN #else IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN #endif CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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.1.2/src/dfac_scalings_simScale_util.F0000664000175000017500000012052013164366266021274 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/ssol_bwd_aux.F0000664000175000017500000011131413164366263016326 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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(40), 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 MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) #if defined(RHSCOMP_BYROWS) REAL RHSCOMP(NRHS,LRHSCOMP) #else REAL RHSCOMP(LRHSCOMP,NRHS) #endif 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 DOUBLE PRECISION :: TIME_TMP 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 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE SMUMPS_OOC 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(40), 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 MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) #if defined(RHSCOMP_BYROWS) REAL RHSCOMP(NRHS,LRHSCOMP) #else REAL RHSCOMP(LRHSCOMP,NRHS) #endif INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED 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(8) :: P_UPDATE, P_SOL_MAS 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_TMP, IPOSINRHSCOMP_PANEL DOUBLE PRECISION :: TIME_TMP INTEGER JBDEB, JBFIN, NRHS_B, allocok 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 MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE, strsv, strsm, sgemv, sgemm 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 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. FEUILLE) 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 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 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP) = W(POSWCB+1+JJ) #else RHSCOMP(IPOSINRHSCOMP,K) = W(POSWCB+1+JJ) #endif ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( KEEP(237).GT. 0 ) 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)), & SLAVEF) .eq. MYID ) THEN IF ( KEEP(237).GT. 0 ) 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 IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF (KEEP(201).GT.0) 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(IW( IPOS + 3 )) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 in 41S : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - LONG*NRHS_B .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 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + NPIV * NRHS_B PLEFTW = P_SOL_MAS + NROW_L * NRHS_B 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).EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE #endif CALL sgemm( 'T', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE #endif CALL sgemm( 'N', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF IF (KEEP(201).GT.0) 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 - NROW_L * NRHS_B 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 ) 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = W2(I) #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) #endif I = I+1 ENDDO ELSE DO JJ = J1,J2 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) + W2(I) #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) #endif 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) 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) 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 )) IF (KEEP(350).EQ.0) THEN DO K=JBDEB, JBFIN DO JJ = J1, J2 W(IFR8+JJ-J1+(K-JBDEB)*LIELL) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif END DO END DO ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*) "Internal error SMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR8 = IFR8 + 1 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(K,IPOSINRHSCOMP_TMP) #else W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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 ELSE WRITE(*,*) "Internal error SMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF IF ( KEEP(201).EQ.1 .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 (KEEP(350).EQ.0) THEN CALL sgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( PTWCB_PANEL + int(NBJ,8) ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ELSE IF (NCB_PANEL - NCB.NE. 0) THEN CALL sgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), & 1, ONE, & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF IF (NCB .NE. 0) THEN CALL sgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + NPIV ), & 1, ONE, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF ENDIF ENDIF IF (KEEP(350).eq.0) THEN CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (KEEP(350).eq.0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(PTWCB_PANEL+int(NBJ,8)),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in SMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else 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 ENDIF ENDIF IF (KEEP(350).eq.0) THEN CALL strsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in SMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL strsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF 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 IF (KEEP(350).EQ.0) THEN CALL sgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & W(PTRACB(STEP(INODE))), 1 ) ELSE CALL sgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE IF (KEEP(350).EQ.0) THEN CALL sgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, W(PTRACB(STEP(INODE))),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in SMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL sgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF END IF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL strsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & W(PTRACB(STEP(INODE))),1) ELSE CALL strsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL strsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & W(PTRACB(STEP(INODE))),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in SMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL strsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif 1234 CONTINUE IF (KEEP(201).GT.0) 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO I = 1, NPIV DO K=JBDEB,JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) #else RHSCOMP( IPOSINRHSCOMP_TMP , K ) = & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) #endif ENDDO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*)"Internal error in SMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF IN = INODE 200 IN = FILS(IN) IF (IN .GT. 0) GOTO 200 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, 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 ( KEEP(237).GT.0 ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( KEEP(237).GT.0 ) 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)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & SLAVEF ) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 IF (NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, FEUILLE, 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=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 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 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE DEALLOCATE(DEJA_SEND) RETURN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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.1.2/src/dana_reordertree.F0000664000175000017500000012346513164366263017154 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & 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 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(40) 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)), & SLAVEF))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)), & SLAVEF))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)), & SLAVEF))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)), & SLAVEF))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)),SLAVEF))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)),SLAVEF)))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)),SLAVEF)))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, & 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 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(40) 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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),SLAVEF) 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)),SLAVEF) 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)),SLAVEF))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)),SLAVEF) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE WRITE(*,*)ID,': INODE -> ',INODE,'DF =', & CUR_DEPTH_FIRST_RANK CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & SLAVEF))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & SLAVEF))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.1.2/src/mumps_scotch64.c0000664000175000017500000000245113164366240016544 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html * */ /* Interfacing with 64-bit SCOTCH and pt-SCOTCH */ #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 */ MUMPS_INT8 * const elentab, /* out */ MUMPS_INT8 * const lasttab, /* out */ MUMPS_INT * const ncmpa ) /* out */ { *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); } #endif MUMPS_5.1.2/src/cmumps_save_restore.F0000664000175000017500000000071713164366265017730 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_SAVE_RESTORE_RETURN() RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_RETURN MUMPS_5.1.2/src/mumps_l0_omp_m.F0000664000175000017500000000123413164366241016553 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/dfac_front_LU_type2.F0000664000175000017500000006100113164366264017463 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'dmumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 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(40), 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), & 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)), NBPROCFILS(KEEP(28)), & 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 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 INTEGER PIVOT_OPTION, LAST_COL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER :: NOMP INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF NOMP=1 !$ NOMP=OMP_GET_MAX_THREADS() 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) IF (UUTEMP == 0.0D0 .AND. KEEP(201).NE.1) THEN ENDIF 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= .FALSE. NULLIFY(BEGS_BLR) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) 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 K263 = 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 IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 CNT_NODES = CNT_NODES + 1 CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL SYSTEM_CLOCK(TTOT1FR) ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 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 IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL DMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW, & 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, & IPIV & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. & (KEEP(485).EQ.0) & ) & ) 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 CALL DMUMPS_BUF_TEST() NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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, .FALSE., .TRUE., & .FALSE. ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF CALL DMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 2, 0) ENDIF IF (LR_ACTIVATED) THEN NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 101 ENDIF END_I=NB_BLR ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP(470), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H', 2) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (K263.NE.0) 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR .LT. NASS) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, (PIVOT_OPTION.LT.2), .TRUE. & , (KEEP(377) .EQ. 1) & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF CALL SYSTEM_CLOCK(T1) IF (IEND_BLR.LT.NFRONT) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, .FALSE., .FALSE., & .FALSE. ) ENDIF CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_TRSM_TIME = LOC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR)) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & 0, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), BEGS_BLR(CURRENT_BLR+1), & NPARTSASS, BLR_L, CURRENT_BLR, 'V', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & NFRONT, KEEP(470), & END_I_IN=END_I & ) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) CALL DEALLOC_BLR_PANEL (BLR_L, NPARTSASS-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF (KEEP(201).EQ.1) 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 CALL STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, 0, INODE, & NELIM) CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_FLOP_FRONT_TYPE2(NFRONT, NASS, KEEP(50), & STEP_STATS(INODE), NELIM ) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 480 CONTINUE write(*,*) 'Allocation problem in BLR routine & DMUMPS_FAC_FRONT_LU_TYPE2: ', & 'not enough memory? memory requested = ' , IERROR 490 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE DEALLOCATE( IPIV ) RETURN END SUBROUTINE DMUMPS_FAC2_LU END MODULE DMUMPS_FAC2_LU_M MUMPS_5.1.2/src/dana_driver.F0000664000175000017500000050116413164366266016124 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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, FILS, FRERE, NFSIZ INTEGER NE, NA INTEGER I, allocok INTEGER MAXIS1_CHECK 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, SBUF_REC, 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 C to store the size of the sequencial peak of stack C (or an estimation for not calling REORDER_TREE_N ) DOUBLE PRECISION PEAK C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, DIMENSION(:) :: PAR2_NODES 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_STAT INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED 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 INTEGER, POINTER, DIMENSION(:) :: WORK1PTR, WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR ! Used because of multithreaded SIM_NP_ INTEGER :: locMYID, locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER(kind=8) :: N8, NZ8, LIW8 INTEGER :: LIW_ELT 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 KEEP8(24) = 0_8 ! reinitialize last used size of WK_USER KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) 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 ---------------------------------------- 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 (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) 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 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) C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ) 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 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ---------------------------------------------- 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 ( associated(id%MEM_DIST) ) deallocate( id%MEM_DIST ) 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 ) RETURN 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 ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( KEEP(54) .eq. 3 ) THEN C ----------------------------------------------- C Collect on the host -- if matrix is distributed C at analysis -- all integer information. C ----------------------------------------------- CALL DMUMPS_GATHER_MATRIX(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN END IF C ************************************************ C BEGINNING OF MASTER CODE FOR SEQUENTIAL ANALYSIS C ************************************************ 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. Done before 1234 label in order to avoid C two allocations of size 1 and a memory leak in case C there are two passes (see 1234 label below and C "GOTO 1234" statement) 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 in Schur ' CALL MUMPS_ABORT() END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF 1234 CONTINUE IF ( ( (KEEP(23) .NE. 0) .AND. & ( (KEEP(23).NE.7) .OR. KEEP(50).EQ. 2 ) ) & .OR. & ( associated(id%A) .AND. KEEP(52) .EQ. 77 .AND. & (KEEP(50).EQ.2)) & .OR. & KEEP(52) .EQ. -2 ) THEN C MAXIMUM TRANSVERSAL ALGORITHM called on original matrix. C KEEP(23) = 7 means that automatic choice C of max trans value will be done during Analysis. C We compute a permutation of the original matrix to have zero free diagonal C the col. Permutation is held in IS1(1, ...,N). C Max-trans (DMUMPS_ANA_O) is not used for element entry. IF (.not.associated(id%A)) THEN C -- If maxtrans is required and A not allocated then reset C -- it to structural based maxtrans. IF (KEEP(23).GT.2) KEEP(23) = 1 ENDIF CALL DMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%IS1(1), id, & ICNTL(1), INFO(1)) IF (INFO(1) .LT. 0) THEN C ----------- C Fatal error C ----------- C Permutation was not computed; reset keep(23) KEEP(23) = 0 GOTO 10 END IF END IF C END OF MAX-TRANS ON THE MASTER C C ********************************************************** C C BEGINNING OF ANALYSIS, STILL ON THE MASTER C C Set up subdivisions of arrays for analysis C C ------------------------------------------------------ C Define the size of a working array C that will be used as workspace DMUMPS_ANA_F. 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 N8=int(id%N,8) IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=int(id%KEEP8(28),8) IF ( KEEP(256) .EQ. 1 ) THEN ! KEEP(256) <-- ICNTL(7) LIW8 = 2_8 * NZ8 + N8 + 1_8 ELSE LIW8 = 2_8 * NZ8 + N8 + 1_8 ENDIF 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*N8) LIW8 = 3_8*N8 ELSE IF (LIW_ELT.LT.3*id%N) LIW_ELT = 3*id%N ENDIF IF (KEEP(23) .NE. 0) THEN IKEEP = id%N + 1 ELSE IKEEP = 1 END IF NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N MAXIS1_CHECK = NFSIZ + id%N - 1 C C ANALYSIS PHASE C Some workspace of DMUMPS_ANA_F can be reused in subsequent phases. C IS(IKEEP) OF LENGTH 3*N C IS(NFSIZ) OF LENGTH N holds the frontal matrix sizes C IS(FILS) and IS(FRERE) OF LENGTH N holds the assembly tree C IF ( KEEP(256) .EQ. 1 ) THEN C Note that id%PERM_IN has been checked before. DO I = 1, id%N id%IS1( IKEEP + I - 1 ) = id%PERM_IN( I ) END DO 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 CALL DMUMPS_ANA_F(id%N, id%KEEP8(28), & id%IRN(1), id%JCN(1), & LIW8, id%IS1(IKEEP), & KEEP(256), id%IS1(NFSIZ), & id%IS1(FILS), id%IS1(FRERE), & id%LISTVAR_SCHUR(1), SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1),id%NSLAVES, & id%IS1(1),id) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max trans KEEP(23) = -KEEP(23) IF (.NOT. associated(id%A)) KEEP(23) = 1 GOTO 1234 ENDIF INFOG(7) = KEEP(256) 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, & id%IS1(IKEEP), & KEEP(256), id%IS1(NFSIZ), id%IS1(FILS), & id%IS1(FRERE), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1)) 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 ) 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) C Check error during DMUMPS_ANA_F OR DMUMPS_ANA_F_ELT IF ( INFO(1) .LT. 0 ) THEN GO TO 10 ENDIF ENDIF ELSE C Parallel analysis IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N IF (id%MYID .EQ. MASTER) THEN C this correspond to the old PTRAR part of IS1 C WORK2PTR => id%IS1(PTRAR : PTRAR + 4*id%N-1) ALLOCATE(WORK2PTR(4*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(WORK1PTR(3*id%N),WORK2PTR(4*id%N), stat=IERR ) ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN INFO( 2 ) = 4*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 ) RETURN IF(id%MYID .EQ. MASTER) THEN WORK1PTR => id%IS1(IKEEP : IKEEP + 3*id%N-1) NFSIZPTR => id%IS1(NFSIZ : NFSIZ + id%N-1) FILSPTR => id%IS1(FILS : FILS + id%N-1) FREREPTR => id%IS1(FRERE : FRERE + id%N-1) END IF CALL DMUMPS_ANA_F_PAR(id, & WORK1PTR, & WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR) DEALLOCATE(WORK2PTR) IF(id%MYID .EQ. 0) THEN NULLIFY(WORK1PTR, NFSIZPTR) NULLIFY(FILSPTR, FREREPTR) ELSE DEALLOCATE(WORK1PTR) END IF KEEP(28) = INFOG(6) END IF 10 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN 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(id%N, id%IS1(FILS), id%IS1(FRERE), & id%IS1(NE), id%IS1(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 id%KEEP(20)=0 id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C id%PROCNODE = 0 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 CALL DMUMPS_SET_PROCNODE(id%KEEP(38), id%PROCNODE(1), & 1+2*id%NSLAVES, id%IS1(FILS),id%N) 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 => id%IS1(IKEEP:IKEEP+id%N-1) C Map nodes and assign candidates for dynamic scheduling CALL DMUMPS_DIST_AVOID_COPIES(id%N,id%NSLAVES,ICNTL(1), & INFOG(1), & id%IS1(NE), & id%IS1(NFSIZ), & id%IS1(FRERE), & id%IS1(FILS), & KEEP(1),KEEP8(1),id%PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & ) 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(id%N, id%IS1(FILS), & id%IS1(FRERE), id%IS1(NE), & id%IS1(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN 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) ) 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 ) RETURN 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, id%IS1(FRERE), & id%IS1(FILS), & id%IS1(IKEEP+id%N), id%IS1(IKEEP+2*id%N), 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 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 numbers. C This is used later in the initial elemental C matrix distribution at the beginning of the factorisation phase C --------------------------------------- CALL DMUMPS_ELTPROC(id%N, NELT, id%ELTPROC(1),id%NSLAVES, & id%PROCNODE(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, id%N IF ( ( id%IS1(FRERE+INODE-1) .NE. id%N+1 ) .AND. & ( MUMPS_TYPENODE(id%PROCNODE(INODE),id%NSLAVES) & .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 * =============================== * ! blocking factor for multiple RHS for ana_distm KEEP(84) = ICNTL(27) END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. 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 MUMPS_BCAST_I8( id%KEEP8(21), MASTER, & id%MYID, 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 ----------------- C Broadcast LR related keep informations KEEP(483-492) C if includes MPI_BCAST(idKEEP(486) CALL MPI_BCAST( id%KEEP(483), 10, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Save setting (used later during factorization) C to enable BLR KEEP(494) = KEEP(486) 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 C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) 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 CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 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 CALL MUMPS_REALLOC(id%LRGROUPS, id%N, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. IF ( associated( id%UNS_PERM ) ) deallocate(id%UNS_PERM) C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID == MASTER .AND. id%KEEP(23) .NE. 0 ) THEN C This one is only on the master allocate(id%UNS_PERM(id%N),stat=allocok) IF ( allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = id%N IF ( LPOK ) THEN WRITE(LP, 150) 'id%UNS_PERM' END IF GOTO 94 ENDIF C DO I=1,id%N id%UNS_PERM(I) = id%IS1(I) END DO ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN DO I=1,id%N id%FILS(I) = id%IS1(FILS+I-1) ENDDO END IF 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 (id%N.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (id%IS1(NA+id%N-1) .LT.0) THEN NBLEAF = id%N NBROOT = id%N ELSE IF (id%IS1(NA+id%N-2) .LT.0) THEN NBLEAF = id%N-1 NBROOT = id%IS1(NA+id%N-1) ELSE NBLEAF = id%IS1(NA+id%N-2) NBROOT = id%IS1(NA+id%N-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) IF(INFO(1).LT.0) GOTO 96 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 ( id%N == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (id%IS1(NA+id%N-1) < 0) THEN id%NA(LEAF) = - id%IS1(NA+id%N-1)-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO ELSE IF (id%IS1(NA+id%N-2) < 0 ) THEN INODE = - id%IS1(NA+id%N-2) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO END IF END IF 96 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF ( id%MYID .EQ. MASTER ) THEN 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, id%N IF ( id%IS1(FRERE+I-1) .ne. id%N + 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 = id%IS1(FILS+I-1) DO WHILE ( INN .GT. 0 ) id%STEP(INN) = - ISTEP INN = id%IS1(FILS + INN -1) END DO IF (id%IS1(FRERE+I-1) .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' CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ DO I = 1, id%N IF (id%IS1(FRERE+I-1) .NE. id%N+1) THEN id%PROCNODE_STEPS(id%STEP(I)) = id%PROCNODE( I ) id%FRERE_STEPS(id%STEP(I)) = id%IS1(FRERE+I-1) id%NE_STEPS(id%STEP(I)) = id%IS1(NE+I-1) id%ND_STEPS(id%STEP(I)) = id%IS1(NFSIZ+I-1) ENDIF ENDDO C =============================== C Algoritme 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, id%N C -- skip non principal nodes IF ( id%STEP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (id%IS1(FRERE+I-1) .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 = id%IS1(FILS+I-1) DO WHILE ( IFS .GT. 0 ) IFS= id%IS1(FILS + IFS -1) 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 = id%IS1(FRERE+IFS-1) ENDDO END DO C C C Following arrays (PROCNODE and IS1) not used anymore C during analysis DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) DEALLOCATE(id%IS1) NULLIFY(id%IS1) 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. 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%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 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 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%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 C Compute a grouping of variables for LR approximations. C id%SYM_PERM is used as a work array IF(KEEP(486) .EQ. 1) THEN IF ( (KEEP(54).eq.3) .AND. (KEEP(244).eq.2) ) THEN C If the input matrix is distributed and the parallel analysis is C chosen, the graph has to be centralized in order to compute the C clustering. CALL DMUMPS_GATHER_MATRIX(id) END IF IF (KEEP(469).EQ.0) THEN CALL DMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN(1), & id%JCN(1), id%FILS(1), id%FRERE_STEPS(1), & id%DAD_STEPS(1), id%NE_STEPS(1), id%STEP(1), id%NA(1), & id%LNA, id%LRGROUPS(1), & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), id%KEEP(489), & 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), LPOK, LP) ELSE CALL DMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN(1), & id%JCN(1), id%FILS(1), id%FRERE_STEPS(1), & id%DAD_STEPS(1), id%NE_STEPS(1), id%STEP(1), id%NA(1), & id%LNA, id%LRGROUPS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), id%KEEP(489), & 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), LPOK, LP) ENDIF IF ( (KEEP(54).eq.3) .AND. (KEEP(244).eq.2) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above deallocate(id%IRN, id%JCN) NULLIFY(id%IRN) NULLIFY(id%JCN) END IF END IF CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 80 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%INFO(1) ) ELSE ! matches the IF (id%MYID .EQ. MASTER) THEN ... above CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 80 IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2) & .AND. (abs(KEEP(486)).EQ.1)) THEN C If the input matrix is distributed and the parallel analysis is C chosen, the graph has to be centralized in order to compute the C clustering. CALL DMUMPS_GATHER_MATRIX(id) END IF ENDIF C Root principal variable C for scalapack (KEEP(38)) might have been updated C since root variables might have been permuted. C It should thus be redistributed to all procs IF((abs(KEEP(486)) .EQ. 1).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 ) RETURN 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(486).EQ.1) 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_PAR, 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_PAR(id, id%PTRAR(1)) 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 DEALLOCATE( id%IRN ) DEALLOCATE( id%JCN ) 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)) & deallocate(id%DEPTH_FIRST) 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)) * DEALLOCATE(id%DEPTH_FIRST_SEQ) 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)) * DEALLOCATE(id%SBTR_ID) 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)) & deallocate(id%DEPTH_FIRST) 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)) * DEALLOCATE(id%DEPTH_FIRST_SEQ) 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)) * DEALLOCATE(id%SBTR_ID) 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)) & deallocate(id%COST_TRAV) 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)) & deallocate(id%COST_TRAV) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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 ) RETURN 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)) deallocate(id%CANDIDATES) 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 ) RETURN 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 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 ! defined(OLD_LOAD_MECHANISM) 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%NSLAVES) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO #endif 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 ) RETURN C ------------------------------ C Perform again the subdivision of array C IS1, both on the master and on C the slaves. This is done so to C ease the passage to the model C where master will work. C ------------------------------ C IF ( KEEP(23).NE.0 .and. id%MYID .EQ. MASTER ) THEN IKEEP = id%N + 1 ELSE IKEEP = 1 END IF FILS = IKEEP + 3 * id%N NE = IKEEP + 2 * id%N NA = IKEEP + id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N 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 ) RETURN IF ( I_AM_SLAVE ) THEN 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 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 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 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)) ENDIF CALL DMUMPS_ANA_DISTM( locMYID_NODES, id%N, & id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), id%DAD_STEPS(1), & id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, & KEEP8(11), KEEP(26), KEEP(15), & KEEP8(12), ! formerly KEEP(16), & KEEP8(14), ! formerly KEEP(200), & KEEP(224), KEEP(225), & KEEP(27), RINFO(1), & KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, SBUF_RECOLD8, & SBUF_SEND, SBUF_REC, 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(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) + 2* 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) + 2* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) C size of S KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) C size of S KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /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 = max(SBUF_SEND,KEEP(27)) SBUF_REC = max(SBUF_REC ,KEEP(27)) CALL MPI_ALLREDUCE (SBUF_REC, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43)=KEEP(44) ELSE KEEP(43)=SBUF_SEND 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(43) = max(KEEP(43), 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 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 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0D0 END IF 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 -------------------------------------- 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) CALL MUMPS_REDUCEI8( KEEP8(11), KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) C -------------- C Flops estimate C -------------- CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_DOUBLE_PRECISION, MPI_SUM, & id%COMM, IERR) 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) ) 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 IN-CORE MEMORY STATISTICS C ========================= OOC_STAT = KEEP(201) IF (KEEP(201) .NE. -1) OOC_STAT=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_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(2) = TOTAL_BYTES 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_STAT, PERLU_ON, TOTAL_BYTES) IF ( PROK ) THEN WRITE(MP,'(A,I10) ') & ' Estimated space in MBYTES for IC factorization :', & 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 WRITE( MPG,'(A,I16) ') & ' ** Rank of proc needing largest memory in IC facto :', & IRANK WRITE( MPG,'(A,I16) ') & ' ** Estimated corresponding MBYTES for IC facto :', & id%INFOG(16) IF ( KEEP(46) .eq. 0 ) THEN C Host not working WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,(id%INFOG(17)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,id%INFOG(17)/id%NSLAVES END IF WRITE(MPG,'(A,I16) ') & ' ** TOTAL space in MBYTES for IC factorization :' & ,id%INFOG(17) END IF C ========================================= C NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS C (except when OOC_STAT is equal to -1 in C which case IC and OOC statistics are C identical) C ========================================= OOC_STAT = KEEP(201) #if defined(OLD_OOC_NOPANEL) IF (OOC_STAT .NE. -1) OOC_STAT=2 #else IF (OOC_STAT .NE. -1) OOC_STAT=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_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(3) = TOTAL_BYTES 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_STAT, PERLU_ON, TOTAL_BYTES) id%INFO(17) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I16) ') & ' ** Rank of proc needing largest memory for OOC facto :', & IRANK WRITE( MPG,'(A,I16) ') & ' ** Estimated corresponding MBYTES for OOC facto :', & id%INFOG(26) IF ( KEEP(46) .eq. 0 ) THEN C Host not working WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,(id%INFOG(27)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,id%INFOG(27)/id%NSLAVES END IF WRITE(MPG,'(A,I16) ') & ' ** TOTAL space in MBYTES for OOC factorization :' & ,id%INFOG(27) END IF c #endif 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)) & deallocate( id%MAPPING) 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 CALL DMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & id%IRN(1),id%JCN(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 ) RETURN KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 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 Fwd in facto 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 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 IF ( PROKG ) THEN WRITE(MPG, '(A)') & ' Resetting candidate strategy to 0 because NSLAVES=1' WRITE(MPG, '(A)') ' ' END IF 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 IF ( PROKG ) THEN WRITE(MPG, '(A)') & ' Resetting candidate strategy to 8 ' WRITE(MPG, '(A)') ' ' END IF 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 ---------------------------- 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 kept for backward compatibility.' 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 * * Graph modification prior to ordering (id%ICNTL(12) option) * id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) * id%KEEP(95) = id%ICNTL(12) 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) = 0 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 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) = 7 C still forbid max trans for LLT IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not compatible with LLT 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 compatible with LLT 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).NE.0) 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 id%KEEP(95) = 1 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans 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)') & ' ** Max-trans not allowed because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN C Only Ruiz & Bora scaling available for dist format C (Work supported by ANR-SOLSTICE (ANR-06-CIS6-010)) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed (matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(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)') & ' ** Max-trans not allowed for element matrix' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling not allowed at analysis for element matrix' 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(39).NE.1 .and. id%ICNTL(39).NE.2) 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(39) 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(16) (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 -- Block low rank input parameter checking id%KEEP(486) = id%ICNTL(35) C KEEP(486)!=0,1 => KEEP(486)=0 IF (id%KEEP(486).NE.1) id%KEEP(486) = 0 IF(id%KEEP(486).NE.0) THEN C tests that may switch off BLR C C LR is incompatible with elemental matrices IF (id%KEEP(55).NE.0) THEN IF (PROK) WRITE(MP,*) & "WARNING: BLR feature currently incompatible " & ,"with elemental matrices" C Switch off BLR id%KEEP(486)=0 ENDIF C C LR incompatible with forward in facto in facto IF (id%KEEP(252).NE.0) THEN IF (PROK) WRITE(MP,*) & "WARNING: BLR feature currently incompatible " & ,"with forward during factorization" C Switch off BLR id%KEEP(486)=0 ENDIF IF((id%KEEP(492).EQ.0)) THEN id%KEEP(486)=0 ENDIF ENDIF C IF(id%KEEP(486).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(470)=0 or 1 IF ((id%KEEP(470).NE.0).AND.(id%KEEP(470).NE.1)) THEN id%KEEP(470)=1 ENDIF 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(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(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=4 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 IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 write(*,*) 'KEEP(480) = 0 => Resetting KEEP(474) to 0' ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 write(*,*) 'KEEP(480) < 4 => Resetting KEEP(478) to 0' ENDIF C In LUA strategy KEEP(480)>=5, we exploit LRTRSM to further C reduce the flops. It requires KEEP(475)>=2. 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 IF (id%KEEP(474).EQ.3) THEN write(*,*) 'KEEP(480) = ',id%KEEP(480), & ' and KEEP(474) = 3 ', & 'requires KEEP(475) >= 2, but it is = ', id%KEEP(475) ELSE write(*,*) 'KEEP(480) = ',id%KEEP(480), & 'requires KEEP(475) >= 2, but it is = ', id%KEEP(475) ENDIF 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 C id%KEEP(481)=0,1,2 IF ((id%KEEP(481).GT.2).OR.(id%KEEP(481).LT.0)) THEN id%KEEP(481)=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 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(485)>0 IF((id%KEEP(485).LT.0)) THEN id%KEEP(485)= 1 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(489)=0 or 1 IF ((id%KEEP(489).NE.0).AND.(id%KEEP(489).NE.1)) THEN id%KEEP(489)=0 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 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' TYPE(DMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: MASTER, IERR, INDX INTEGER :: STATUS(MPI_STATUS_SIZE) 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 PARAMETER( MASTER = 0 ) 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 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 GOTO 13 ENDIF 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)/20_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, opens a file and dumps the matrix and/or C the right hand side. This subroutine calls C DMUMPS_DUMP_MATRIX and DMUMPS_DUMP_RHS. C The routine should be called on all processors. C INCLUDE 'mpif.h' C Arguments C ========= TYPE(DMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED INTEGER :: MM_WRITE INTEGER :: MM_WRITE_CHECK CHARACTER(LEN=20) :: MM_IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER 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) 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 (id%WRITE_PROBLEM(1:20) .NE. "NAME_NOT_INITIALIZED")THEN 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 CLOSE(IUNIT) ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN C ===================== C Matrix is distributed C ===================== IF (id%WRITE_PROBLEM(1:20) .EQ. "NAME_NOT_INITIALIZED" & .OR. .NOT. I_AM_SLAVE )THEN MM_WRITE = 0 ELSE MM_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(MM_WRITE, MM_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 (MM_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(MM_IDSTR,'(I9)') id%MYID_NODES OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(MM_IDSTR))) CALL DMUMPS_DUMP_MATRIX(id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL ) ! Elemental or not CLOSE(IUNIT) ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. & id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED")THEN OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL DMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE DMUMPS_DUMP_PROBLEM SUBROUTINE DMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL ) 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 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)) 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)) 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)) 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)) 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" WRITE(IUNIT,*) id%A_ELT(:) 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, K, LD_RHS 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_RHS = id%N ELSE LD_RHS = id%LRHS ENDIF DO J = 1, id%NRHS DO I = 1, id%N K=(J-1)*LD_RHS+I WRITE(IUNIT,*) id%RHS(K) 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 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, K489, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & LPOK, LP) USE DMUMPS_ANA_LR C This routine is meant to compute a grouping of the variables in C all the separators. This grouping defines the blocks that will C be compressed by means of low-rank approximations. Because the C principal variables of all separators will be changed, it is C necessary to update the arrays FILS, FRERE_STEPS, DAD_STEPS, STEP, C NA. C C N - the size of the input matrix C NZ8 - the nnz in the input matrix C NSTEPS - the numbers of nodes in the tree C IRN - the row indices of the input matrix C JCN - the col indices of the input matrix C FILS - the fils array of size N. This array will be C modified on output according to the new relative C order computed for the variables in the separators C FRERE_STEPS - the FRERE_STEPS array. Modified on output (as for FILS) C DAD_STEPS - the DAD_STEPS array. Modified on output (as for FILS) C NE_STEPS - the NE_STEPS array. Modified on output (as for FILS) C STEP - the STEP array. Modified on output (as for FILS) C NA - the NA array. Modified on output (as for FILS) C LNA - The length of the NA array C LRGROUPS - the array mapping variables onto groups. C LRGROUPS(i)=k means that variable i belongs to C group k C SYM - the type of matrix (KEEP(50)) C ICNTL - the ICNTL array C HALO_DEPTH - the depth of the halo around the separator subgraph C GROUP_SIZE - the size of variables groups in the separators C K489 - BLR strategy (=3 compress CB) C SEP_SIZE - the minimum size of a separator to be treated with C low-rank approximations C has to be used for computing the clustering C IFLAG - < 0 in case of error C IERROR - complementary information in case of error C e- =0 upon succesful return, > 0 otherwise C C LP, LPOK to control error printing C C C This routine traverses the tree in a DFS fashion using a pool C where nodes are pushed as soon as their parent is treated. Nodes C are pushed in the pool in the same order as FRERE_STEPS and, since C nodes are popped from the head of this pool, this means that C siblings are treated in reverse order. This makes it easier to C modify FRERE_STEPS because it will be always updated wrt a node C which has already been treated. The update of NA relies on the C assumption that a DFS touches the leaves in the same order as they C appear in NA (in reverse order in this case for what said above). C The roots are therefore pushed in the pool in reverse order. C An array of order NSTEPS is allocated to store the principal C variables of all the nodes that have been treated. This array C could be spared at the price of expensive pointer chasing inside C FILS. IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE, K489 INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: IRN(NZ8), JCN(NZ8), NE_STEPS(NSTEPS), & ICNTL(40) INTEGER, INTENT(INOUT) :: FILS(N), FRERE_STEPS(NSTEPS), STEP(N), & NA(LNA), DAD_STEPS(NSTEPS), LRGROUPS(N) 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 INTERFACE 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) INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) END SUBROUTINE END INTERFACE C Check for Schur (// or sequential) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF C If automatic choice of partitioning tool is required, then metis C comes first, if available; otherwise scotch; otherwise C permuted matrix is simply split. C If a particular tool C is required, we check for its availability, otherwise we revert to C automatic choice 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 C The global number of groups computed NBGROUPS = 0 C Build the unsymmetrized graph of the input matrix. The LGROUPS C array will be immediately allocated and used as a scratchpad C memory for DMUMPS_ANA_GNEW IF (K265.EQ.-1) THEN C unsymmetric matrix, structurally symmetric LW = NZ8 ELSE C worst case need to double matrix size 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, IWFR, NRORM, NIORM, IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265) IF (allocated(IQ)) DEALLOCATE(IQ) C LRGROUPS has been used as a workspace in ana_gnew so we should C reinitialize it to -1 to be sure that a variable which is in no C group (ie in no grouped separator) can be identified correctly LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS C Push the roots in the pool in reverse order C DO I = 1, NROOTS C POOL(I) = NA(2+NLEAVES+NROOTS-I+1) C END DO C BUGFIX 18/11/2016 C Because the elements from the pool are taken in reverse order and the C NA is also updated in reverse order in MUMPS_UPD_TREE, this was C actually false! The roots should be pushed in the pool in natural C order. Cf email "Bugs L0" 18/11/2016. DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS C arrays of size N used to computed each halo 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 C Loop until the pool is empty DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) C This variable tells whether node is the oldest son of its parent. C In this case fils(fils(...fils(dad_steps(node)))) is updated FIRST = POOL(PP) .LT. 0 C Go down until the last variable in this front and make a list of C the fully assembled variables in it inside the work array NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO C Do the grouping. Upon return, work contains the variable in the C new order and NBGROUPS has been increased by the number of groups C computed in the current separator C Grouping is done if the current node is large enough, i.e. bigger C than the cluster size GROUP_SIZE. The grouping must be done C even if NV is smaller than SEP_SIZE: in that case, we give to all C of its variables a negative group number so that we have grouping C for all the variables which is needed in case we have for example C a chain like (say we do low-rank if nass > 8) father (nass=5) son (nass=10) C in this case we need a clustering of the CB of 'son' which may be partly C inherited from the clustering of the FS of 'father' so this latter C clustering should be done even if 'father' is not eligible for LR. Not C likely to happen often with metis-like ordering but it should be done C for robustness. C Moreover, as a front can be chosen for LR during facto even if the C separator was too small for proper grouping ( this occurs with delayed C pivots), we need the negative sign to avoid trying to do a LR facto in C such a case. 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 C Disable permutation/clustering. Leaves the ordering unchanged C and simply pack variables into groups of size SIZE_GROUP. C NB: this doesn't care about FS/CB, or about slaves, etc, so C it is useful only for a NIV1 root basically. DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+I/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + NV/GROUP_SIZE2 + 1 ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS(1), 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 C If NV is smaller than GROUP_SIZE then all variables are in a C single group, which value is negative if NV is also smaller C than SEP_SIZE. 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 C be careful, both val and -val are not present in the LRGROUPS array ENDIF C Update the tree according to the newly computed order CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS(1), FRERE_STEPS(1), STEP(1), DAD_STEPS(1), & NE_STEPS(1), NA(1), LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN C Restore potentially modified root number IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF C Put all the children of node in the pool. The first child is C always pushed with a negative index in order to establish when to C update the FILS array for the last variable in its parent (through C the FIRST variable above) 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) C RETURN END SUBROUTINE DMUMPS_LR_GROUPING SUBROUTINE DMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, K489, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, LPOK, LP) USE DMUMPS_ANA_LR C This routine is meant to compute a grouping of the variables in C all the separators. This grouping defines the blocks that will C be compressed by means of low-rank approximations. Because the C principal variables of all separators will be changed, it is C necessary to update the arrays FILS, FRERE_STEPS, DAD_STEPS, STEP, C NA. C C N - the size of the input matrix C NZ8 - the nnz in the input matrix C NSTEPS - the numbers of nodes in the tree C IRN - the row indices of the input matrix C JCN - the col indices of the input matrix C FILS - the fils array of size N. This array will be C modified on output according to the new relative C order computed for the variables in the separators C FRERE_STEPS - the FRERE_STEPS array. Modified on output (as for FILS) C DAD_STEPS - the DAD_STEPS array. Modified on output (as for FILS) C NE_STEPS - the NE_STEPS array. Modified on output (as for FILS) C STEP - the STEP array. Modified on output (as for FILS) C NA - the NA array. Modified on output (as for FILS) C LNA - The length of the NA array C LRGROUPS - the array mapping variables onto groups. C LRGROUPS(i)=k means that variable i belongs to C group k C SYM - the type of matrix (KEEP(50)) C ICNTL - the ICNTL array C HALO_DEPTH - the depth of the halo around the separator subgraph C GROUP_SIZE - the size of variables groups in the separators C SEP_SIZE - the minimum size of a separator to be treated with C low-rank approximations C has to be used for computing the clustering C IFLAG - < 0 in case of error C IERROR - complementary information in case of error C e- =0 upon succesful return, > 0 otherwise C C LP, LPOK to control error printing C C C This routine traverses the tree in a DFS fashion using a pool C where nodes are pushed as soon as their parent is treated. Nodes C are pushed in the pool in the same order as FRERE_STEPS and, since C nodes are popped from the head of this pool, this means that C siblings are treated in reverse order. This makes it easier to C modify FRERE_STEPS because it will be always updated wrt a node C which has already been treated. The update of NA relies on the C assumption that a DFS touches the leaves in the same order as they C appear in NA (in reverse order in this case for what said above). C The roots are therefore pushed in the pool in reverse order. C An array of order NSTEPS is allocated to store the principal C variables of all the nodes that have been treated. This array C could be spared at the price of expensive pointer chasing inside C FILS. IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE, K489 INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: IRN(NZ8), JCN(NZ8), NE_STEPS(NSTEPS), & ICNTL(40) INTEGER, INTENT(INOUT) :: FILS(N), FRERE_STEPS(NSTEPS), STEP(N), & NA(LNA), DAD_STEPS(NSTEPS), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, TARGET, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, POINTER, DIMENSION (:) :: TRACE_PTR, WORKH_PTR, & GEN2HALO_PTR INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR INTERFACE 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) INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) END SUBROUTINE END INTERFACE C Check for Schur (// or sequential) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF C If automatic choice of partitioning tool is required, then metis C comes first, if available; otherwise scotch; otherwise C permuted matrix is simply split. C If a particular tool C is required, we check for its availability, otherwise we revert to C automatic choice 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 C The global number of groups computed NBGROUPS = 0 C Build the unsymmetrized graph of the input matrix. The LGROUPS C array will be immediately allocated and used as a scratchpad C memory for DMUMPS_ANA_GNEW 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, IWFR, NRORM, NIORM, IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265) IF (allocated(IQ)) DEALLOCATE(IQ) C LRGROUPS has been used as a workspace in ana_gnew so we should C reinitialize it to -1 to be sure that a variable which is in no C group (ie in no grouped separator) can be identified correctly LRGROUPS = -1 IF (K469.NE.2) THEN C K469=1 or 3: arrays of size N shared by all threads 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 !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, !$OMP& WORKH_PTR, TRACE_PTR, GEN2HALO_PTR) IF(K469.GT.1) ALLOCATE(WORK(MAXFRONT), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT IFLAG = -7 IERROR = MAXFRONT GOTO 500 ENDIF IF (K469.EQ.2) THEN C K469=2: arrays of size N allocated on each thread ALLOCATE(TRACE_PTR(N), WORKH_PTR(N), GEN2HALO_PTR(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 500 ENDIF ELSE TRACE_PTR => TRACE WORKH_PTR => WORKH GEN2HALO_PTR => GEN2HALO ENDIF IF (K469.EQ.2) THEN TRACE_PTR = 0 ELSE !$OMP SINGLE TRACE_PTR = 0 !$OMP END SINGLE ENDIF C I) Parcours parallele en N pour initialiser PVS PVSCHANGED = .FALSE. !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO C II) Parcours parallele en NSTEPS pour faire le grouping avec C PVS, STEP et FILS (sauf derniere variable) qui sont mis a jour !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) C Construire VLIST a partir de FILS(PV) C Go down until the last variable in this front and make a list of C the fully assembled variables in it inside the work array NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO C Appel a SEP_GROUPING sur VLIST: la variable principale de NODE C change et devient PVS(NODE) C Do the grouping. Upon return, work contains the variable in the C new order and NBGROUPS has been increased by the number of groups C computed in the current separator C Grouping is done if the current node is large enough, i.e. bigger C than the cluster size GROUP_SIZE. The grouping must be done C even if NV is smaller than SEP_SIZE: in that case, we give to all C of its variables a negative group number so that we have grouping C for all the variables which is needed in case we have for example C a chain like (say we do low-rank if nass > 8) father (nass=5) son (nass=10) C in this case we need a clustering of the CB of 'son' which may be partly C inherited from the clustering of the FS of 'father' so this latter C clustering should be done even if 'father' is not eligible for LR. Not C likely to happen often with metis-like ordering but it should be done C for robustness. C Moreover, as a front can be chosen for LR during facto even if the C separator was too small for proper grouping ( this occurs with delayed C pivots), we need the negative sign to avoid trying to do a LR facto in C such a case. 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 C C Disable permutation/clustering. Leaves the ordering unchanged C and simply pack variables into groups of size SIZE_GROUP. C NB: this doesn't care about FS/CB, or about slaves, etc, so C it is useful only for a NIV1 root basically. !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+I/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + NV/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS(1), NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PTR, WORKH_PTR, & NODE, GEN2HALO_PTR, K482_LOC, K472, K469, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) CYCLE C Maj de PVS PVS(NODE) = WORK(1) PVSCHANGED = .TRUE. C Maj de STEP 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 C Maj de FILS DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN C La derniere variable de FILS memorise l'ancienne C variable principale pointee FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE C If NV is smaller than GROUP_SIZE then all variables are in a C single group, which value is negative if NV is also smaller C than SEP_SIZE. !$OMP CRITICAL(lrgrouping_cri) 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 !$OMP END CRITICAL(lrgrouping_cri) ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 C <<<< Synchro >>>> C A ce stade tous les noeuds ont ete traites et PVS, STEP et FILS (sauf derniere variable) C sont a jour C On economise les maj suivantes si inutiles IF (.NOT.PVSCHANGED) GOTO 500 C III) Maj de DAD_STEPS, FRERE_STEPS, NA, et derniere variable de chaque noeud de FILS !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN C Node has a younger brother, update frere_steps(node) FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN C node is the youngest brother, update frere_steps(node) to make C it point to the father 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.EQ.2) THEN DEALLOCATE(TRACE_PTR) DEALLOCATE(WORKH_PTR) DEALLOCATE(GEN2HALO_PTR) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469.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) C RETURN END SUBROUTINE DMUMPS_LR_GROUPING_NEW C SUBROUTINE SEP_GROUPING(NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, C & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH) C IMPLICIT NONE C INTEGER :: NV, N, NZ, LW, NBGROUPS, GROUP_SIZE, HALO_DEPTH C INTEGER :: VLIST(NV), LRGROUPS(N), IW(LW), IPE(N+1), LEN(N) C C INTEGER :: TMP, I C CC Just invert the list C DO I=1, NV/2 C TMP = VLIST(I) C VLIST(I) = VLIST(NV-I+1) C VLIST(NV-I+1) = TMP C END DO C C RETURN C END SUBROUTINE SEP_GROUPING MUMPS_5.1.2/src/zfac_process_bf.F0000664000175000017500000000071313164366265016767 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE ZMUMPS_PROCESS_BF_RETURN MUMPS_5.1.2/src/dfac_omp_m.F0000664000175000017500000000117613164366266015730 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C C SUBROUTINE DMUMPS_FAC_L0_OMP_RETURN() C C Research work on multithreaded tree parallelism initiated in C the context of the PhD thesis of Wissam Sid-Lakhdar (ENS Lyon) C might impact a future release. C RETURN END SUBROUTINE DMUMPS_FAC_L0_OMP_RETURN MUMPS_5.1.2/src/mumps_scotch_int.h0000664000175000017500000000121313164366240017244 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/src/smumps_comm_buffer.F0000664000175000017500000035647313164366263017546 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 :: 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 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 ) 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) 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 INCLUDE 'mpif.h' INTEGER :: IERR 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) 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 ) CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), IERR ) 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, COMPRESSCB, & 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 COMPRESSCB INCLUDE 'mpif.h' 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) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR) 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 (COMPRESSCB) 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 (COMPRESSCB) 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 ) 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 ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (COMPRESSCB) 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 ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (COMPRESSCB) 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 ) 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 ) 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 ) 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 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 ) 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 ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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 ) ) # if defined(RHSCOMP_BYROWS) REAL RHSCOMP(NRHS,LRHSCOMP) # else REAL RHSCOMP(LRHSCOMP,NRHS) # endif INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' 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 ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_REAL, & COMM, SIZE2, IERR ) 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 ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) IF (NODE2.EQ.0.AND.KEEP(350).NE.0) THEN DO K=1, NRHS_B #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in SMUMPS_BUF_SEND_VCB" CALL MUMPS_ABORT() #else IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1), NPIV, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) 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 ) ENDIF #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 ) 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 ) 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 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 ) 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 ) KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR ) 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 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 ) 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 :: 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 ) 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, & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , LRSTATUS &) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER INODE INTEGER NLIG, NCOL, NASS, NSLAVES 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 SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE_INT = ( 7 + NLIG + NCOL + NSLAVES + 1 ) SIZE_INT = SIZE_INT + 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 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 ) 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 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 ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR) 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 ) 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 ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & COMPRESSCB, KEEP253_LOC ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC INTEGER IPERE, ISON, NBROW 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( * ) LOGICAL DESC_IN_LU, COMPRESSCB 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 NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX INTEGER NBROWS_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: SIZFR, ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, 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) PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' REAL ZERO PARAMETER (ZERO = 0.0E0) 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) CALL MUMPS_GETI8( SIZFR, IW_CBSON( 1 + XXR ) ) 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, PS1, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_REAL, & COMM, SIZE1, IERR ) ENDIF SIZE1 = SIZE1+PS1 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 CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR ) 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, & min( NBROWS_PACKET, NBROW - NBROWS_ALREADY_SENT)) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET * LROW ELSE SIZE_REALS = ( LROW + PERM(1) + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET + ( NBROWS_PACKET * ( NBROWS_PACKET + 1) ) / 2 MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET CALL MPI_PACK_SIZE( SIZE_REALS, MPI_REAL, & COMM, SIZE2, IERR) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR) IF (SIZE2 + SIZE3 .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 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) & 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 ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) ENDDO 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 ) ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( COMPRESSCB ) 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 ( COMPRESSCB ) 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 ) ENDDO 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 ) IF(NFS4FATHER .GT. 0) THEN 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 (COMPRESSCB) 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 (COMPRESSCB) 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 = SIZFR - (SHIFTCB_SON - & int(PS1-1,8) * LDA_SON8) LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC .NE. 0 ) THEN CALL SMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC, & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 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 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 ) 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 ) 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, & SEND_LR, 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) :: SEND_LR INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER :: SEND_LR_INT INTEGER, intent(inout) :: IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' 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 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 ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR ) 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 ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF END IF SIZE2 = 0 CALL MPI_PACK_SIZE(4, MPI_INTEGER, COMM, SIZE3, IERR) SIZE2=SIZE2+SIZE3 IF ( KEEP(50).NE.0 ) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, COMM, SIZE3, IERR) SIZE2=SIZE2+SIZE3 ENDIF IF ((NPIV.GT.0) & ) THEN IF (.NOT. SEND_LR) THEN CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_REAL, & COMM, SIZE3, IERR ) SIZE2 = SIZE2+SIZE3 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), MPI_REAL, & COMM, SIZE3, IERR ) 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 ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) 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 ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( LASTBL .or. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) THEN SEND_LR_INT=1 ELSE SEND_LR_INT=0 ENDIF CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) ENDIF IF (SEND_LR) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_REAL, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) END DO CALL MUMPS_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 ) END DO ENDIF ENDIF CALL MPI_PACK( LRELAY_INFO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( LRELAY_INFO.GT.0) & CALL MPI_PACK( RELAY_INFO, LRELAY_INFO, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) 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 ) 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, & SEND_LR, 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) :: SEND_LR 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) INTEGER :: SEND_LR_INT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' 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 ) SIZE2 = 0 CALL MPI_PACK_SIZE(2, MPI_INTEGER, COMM, SSLR, IERR) SIZE2=SIZE2+SSLR IF (.NOT. SEND_LR) THEN CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_REAL, & COMM, SSLR, IERR ) 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 ) 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 ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) THEN SEND_LR_INT=1 ELSE SEND_LR_INT=0 ENDIF CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) 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 ) 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 ) 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, DIMENSION(:) :: RG2L_ROW INTEGER, DIMENSION(:) :: RG2L_COL 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 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 ) 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) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_REAL, COMM, & SIZE_TMP, IERR) 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 ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_REAL, & COMM, SIZE2, IERR ) 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 ! defined(DBG_SMB3) 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 #endif ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR ) 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 ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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.1.2/src/zfac_process_rtnelind.F0000664000175000017500000001066013164366265020221 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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,ND ) USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' 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) 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)), SLAVEF) 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, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, 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(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.1.2/src/mumps_ooc_common.F0000664000175000017500000001062113164366241017201 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/dfac_scalings_simScaleAbs.F0000664000175000017500000014000513164366266020665 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 Check done outside C IF(ISTATUS + NUMPROCS * MPI_STATUS_SIZE - 1>INTSZ) THEN C write(6,*) "Bora: ", ISTATUS + C & NUMPROCS * MPI_STATUS_SIZE - 1,INTSZ C write(6,*) "Bora : TODO. scimscaent_33 REPORT ERROR" C CALL flush(6) C ENDIF 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 C Check done outside C IF( OSRCPTR + OCSNDRCVVOL - 1 > RESZ) THEN C write(6,*) "Bora: NOTE: ", C & OSRCPTR + OCSNDRCVVOL - 1 , RESZ C write(6,*) "Bora: TODO. scimscaent_3 REPORT ERROR" C CALL flush(6) C 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),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 C write(6,*) 'Bora :', RESZ, N, IRSNDRCVVOL, ORSNDRCVVOL C CALL flush(6) 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(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.1.2/src/cfac_process_root2slave.F0000664000175000017500000002603613164366264020456 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE CMUMPS_LOAD USE CMUMPS_OOC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ), 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) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) 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 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)), & SLAVEF ) ) 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 (KEEP(60) .NE. 0) THEN IF (root%yes) THEN IF ( NEW_LOCAL_M .NE. root%SCHUR_MLOC .OR. & NEW_LOCAL_N .NE. root%SCHUR_NLOC ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_PROCESS_ROOT2SLAVE" CALL MUMPS_ABORT() ENDIF ENDIF PTLUST(STEP(IROOT)) = -4444 PTRFAC(STEP(IROOT)) = -4445_8 PTRIST(STEP(IROOT)) = 0 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 ) 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)) 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 ENDIF GOTO 100 ENDIF 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) 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) GOTO 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 ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB2 compress root2slave: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 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(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQA KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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)) 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 )) .LE. 0 ) THEN PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 IF (LREQA.GT.0_8) A(PTRAST(STEP(IROOT)): & PTRAST(STEP(IROOT))+LREQA-1_8) = ZERO 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(.FALSE., MYID, N, IPOS_SON, & PAMASTER(STEP(IROOT)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 END IF END IF IF (NEW_LOCAL_M.GT.OLD_LOCAL_M) 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 100 CONTINUE NBPROCFILS(STEP(IROOT))=NBPROCFILS(STEP(IROOT)) + TOT_CONT_TO_RECV #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN #endif 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(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.1.2/src/smumps_save_restore_files.F0000664000175000017500000000071313164366263021124 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE SMUMPS_SAVE_FILES_RETURN MUMPS_5.1.2/src/cfac_process_blfac_slave.F0000664000175000017500000004062413164366264020616 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS(KEEP(28)), 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 ) 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 IOLDPS, LCONT1, NROW1, NCOL1, NPIV1, NASS1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok LOGICAL SEND_LR INTEGER SEND_LR_INT 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 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, NB_BLR_COL, NPARTSASS_MASTER INTEGER :: MAXI_CLUSTER_TMP, MAXI_CLUSTER COMPLEX, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX, ALLOCATABLE, DIMENSION(:,:):: BLOCKLR INTEGER :: LWORK REAL,ALLOCATABLE,DIMENSION(:) :: RWORK 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, & SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF IF (SEND_LR) 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))) ALLOCATE(BEGS_BLR_U(NB_BLR_U+2)) CALL CMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, KEEP(470), & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) IF ( LRLU .LT. LAELL ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLUS, IERROR) GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress CMUMPS_PROCESS_BLFAC_SLAVE' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLU, IERROR) GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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 (SEND_LR) THEN DYNAMIC = .FALSE. ENDIF IF (DYNAMIC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN write(*,*) MYID, ' : PB allocation U in blfac_slave ' & , LAELL 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(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) ) #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(INODE)) + 9 + KEEP(IXSZ) ) #else MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 )) POSELT = PTRAST(STEP( INODE )) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NASS1 = IW( IOLDPS + 1 + 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 (SEND_LR) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_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 ( & A, LA, POSELT, IFLAG, IERROR, NCOL1, & BEGS_BLR_LS, BEGS_BLR_U, & CURRENT_BLR_U, & BLR_LS, NB_BLR_LS+1, & BLR_U, NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, KEEP(470), & KEEP(481), DKEEP(8), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR_U, KEEP8, .FALSE.) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) CALL CMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8, .TRUE.) 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( LPOS ), NCOL1, ONE, & A( CPOS ), NCOL1 ) ELSE CALL cgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A( LPOS ), NCOL1, ONE, & A( 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.SEND_LR) THEN IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + 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)), SLAVEF ) 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 IF (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN IOLDPS = PTRIST(STEP( INODE )) CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) NB_BLR_LS = size(BEGS_BLR_LS) - 2 CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 CALL MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_TMP) MAXI_CLUSTER = MAXI_CLUSTER_TMP CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_TMP) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_TMP) LWORK = MAXI_CLUSTER*MAXI_CLUSTER ALLOCATE(RWORK(2*MAXI_CLUSTER),WORK(LWORK),TAU(MAXI_CLUSTER), & JPVT(MAXI_CLUSTER), BLOCKLR(MAXI_CLUSTER,MAXI_CLUSTER), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4) write(6,*) 'ERROR 1 allocate temporary BLR blocks during', & ' CMUMPS_PROCESS_BLFAC_SLAVE ', IERROR GOTO 700 ENDIF CALL CMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, & BEGS_BLR_COL, NB_BLR_COL, NPARTSASS_MASTER, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., 0, KEEP(484)) DEALLOCATE(RWORK,WORK,TAU,JPVT,BLOCKLR) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.1.2/src/dfac_front_LDLT_type1.F0000664000175000017500000004523213164366264017711 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NNEG, NPVW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS & , LRGROUPS & ) 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 !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR, NNEG, NPVW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION UU, SEUIL DOUBLE PRECISION A( LA ) INTEGER, TARGET :: IW( LIW ) 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 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 LOGICAL LASTBL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION,ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok INTEGER :: OMP_NUM DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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 IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU SEUIL_LOC = SEUIL ENDIF PIVOT_OPTION = KEEP(468) 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(BEGS_BLR) 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 (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 IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTBL = .FALSE. IF (KEEP(201).EQ.1) THEN IDUMMY = -8765 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 PIVOT_OPTION = 3 CNT_NODES = CNT_NODES + 1 CALL INIT_STATS_FRONT(NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL INIT_STATS_FRONT(-NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1FR) ENDIF IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL DMUMPS_FAC_I_LDLT(NFRONT,NASS,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEG, 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IF (IFLAG.LT.0) GOTO 500 IF(KEEP(109).GT. 0) THEN IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE & +IW(IOLDPS+5+XSIZE) PIVNUL_LIST(KEEP(109)) = IW(IWPOSP2) ENDIF ENDIF IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN NPVW = NPVW + PIVSIZ IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) 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), & KEEP(253), & PIVOT_OPTION, IEND_BLR & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. (.NOT. COMPRESS_PANEL) .OR. & (KEEP(485).EQ.0) & ) & ) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,IEND_BLR,INODE,A,LA, & LDA, POSELT, & KEEP,KEEP8, & PIVOT_OPTION, .FALSE.) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,NASS,INODE,A,LA, & LDA, POSELT, & KEEP,KEEP8, PIVOT_OPTION, .TRUE.) ELSE CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 1, 1) NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(8), KEEP(477) & ) IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V',1) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR,'V', & NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 IF (COMPRESS_CB) THEN CALL DMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, NPARTSCB+NPARTSASS, & BEGS_BLR, NPARTSCB+NPARTSASS, NPARTSASS, & DKEEP(8), NASS, NFRONT-NASS, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, STEP_STATS(INODE), 1, & .FALSE., 0, KEEP(484)) END IF CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NFRONT-NASS, & KEEP(50), INODE, NASS-NPIV ) CALL STATS_COMPUTE_FLOP_FRONT_TYPE1(NFRONT, NASS, NPIV, & KEEP(50), INODE) LOC_LR_MODULE_TIME = dble(TTOT2-TTOT1)/dble(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (COMPRESS_PANEL) THEN IF ( PIVOT_OPTION.NE.3 & ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_FACTO_NIV1" CALL MUMPS_ABORT() ENDIF ELSE 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) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 490 CONTINUE write(*,*) 'Allocation problem in BLR routine & DMUMPS_FAC_FRONT_LDLT_TYPE1: ', & 'not enough memory? memory requested = ' , IERROR 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC1_LDLT END MODULE DMUMPS_FAC1_LDLT_M MUMPS_5.1.2/src/mumps_type2_blocking.F0000664000175000017500000005014713164366241017773 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C INTEGER FUNCTION MUMPS_BLOC2_GET_NSLAVESMIN & ( SLAVEF, K48, K821, K50, & NFRONT, NCB, K375) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50, NFRONT, NCB, K375 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.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 NSLAVESMIN = max ( NSLAVESMIN/2, 1 ) 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) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50,NFRONT, NCB, K375 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 ) 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) ) 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) IMPLICIT NONE INTEGER, INTENT( IN ) :: NCB, NFRONT, NSLAVES_less, & K48, K50, SLAVEF, NMB_OF_CAND, K375 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 ) NSLAVES = NSLAVES_ref IF ( NSLAVES_ref.LT.SLAVEF ) THEN NSLAVES_max = MUMPS_BLOC2_GET_NSLAVESMAX( & SLAVEF, K48, K821, K50, NFRONT, NCB, K375 ) 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.1.2/src/dtype3_root.F0000664000175000017500000012727513164366263016125 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_ASS_ROOT( NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) IMPLICIT NONE 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 IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON DO J = 1, NCOL_SON-NSUPCOL VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) = & VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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))) 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, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) NBPROCFILS( STEP(IROOT) ) = -1 #if ! defined(NO_XXNBPR) KEEP(121) = -1 #endif IF (IFLAG.LT.0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT)) - 1 #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) - 1 #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN #endif 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(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 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, A( PTRR( STEP(ISON)) + 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, A( PTRR( STEP(ISON)) + 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) 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_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, A( PTRR(STEP(ISON)) + 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, root%RG2L_COL, & 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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 ) IMPLICIT NONE INCLUDE 'dmumps_root.h' 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 ) 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 & ) IMPLICIT NONE INCLUDE 'dmumps_root.h' 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 ) IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE ( DMUMPS_ROOT_STRUC ):: root INTEGER N, IROOT, INFO(40), KEEP(500) INTEGER FILS( N ) INTEGER INODE, I, allocok IF ( associated( root%RG2L_ROW ) ) DEALLOCATE( root%RG2L_ROW ) IF ( associated( root%RG2L_COL ) ) DEALLOCATE( root%RG2L_COL ) 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 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, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IMPLICIT NONE INCLUDE 'dmumps_root.h' 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 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 ) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N ) 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 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 RETURN ENDIF 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, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, 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 RETURN END SUBROUTINE DMUMPS_ROOT_ALLOC_STATIC SUBROUTINE DMUMPS_ASM_RHS_ROOT & ( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) IMPLICIT NONE INCLUDE 'dmumps_root.h' 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 MUMPS_5.1.2/src/sfac_scalings_simScaleAbs.F0000664000175000017500000013707513164366266020721 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 Check done outside C IF(ISTATUS + NUMPROCS * MPI_STATUS_SIZE - 1>INTSZ) THEN C write(6,*) "Bora: ", ISTATUS + C & NUMPROCS * MPI_STATUS_SIZE - 1,INTSZ C write(6,*) "Bora : TODO. scimscaent_33 REPORT ERROR" C CALL flush(6) C ENDIF 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 C Check done outside C IF( OSRCPTR + OCSNDRCVVOL - 1 > RESZ) THEN C write(6,*) "Bora: NOTE: ", C & OSRCPTR + OCSNDRCVVOL - 1 , RESZ C write(6,*) "Bora: TODO. scimscaent_3 REPORT ERROR" C CALL flush(6) C 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),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 C write(6,*) 'Bora :', RESZ, N, IRSNDRCVVOL, ORSNDRCVVOL C CALL flush(6) 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(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.1.2/src/dmumps_f77.F0000664000175000017500000003300313164366263015623 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, 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, & 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, & IRHS_SPARSE, IRHS_SPARSEhere, & IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, & NZ_RHS, LSOL_loc & , & SCHUR_MLOC, & SCHUR_NLOC, & SCHUR_LLD, & MBLOCK, & NBLOCK, & NPROW, & NPCOL, & & OOC_TMPDIR, & OOC_PREFIX, & WRITE_PROBLEM, & TMPDIRLEN, & PREFIXLEN, & WRITE_PROBLEMLEN & & ) 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 JOB, SYM, PAR, COMM_F77, N, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(40), INFO(40), INFOG(40), 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(*), ISOL_loc(*) 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(*) 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 IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, PERM_INhere, WK_USERhere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, IRHS_PTRhere, IRHS_SPARSEhere, ISOL_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 A_ELT_SIZE, I, Np, IERR INTEGER(8) :: 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 mumps_par_array(INSTANCE_NUMBER)%PTR%KEEP(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%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:40)=ICNTL(1:40) 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%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_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 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:A_ELT_SIZE) END IF 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:NRHS*LRHS) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:NRHS*LREDRHS) 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:LSOL_loc*NRHS) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_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 CALL DMUMPS( mumps_par ) INFO(1:40)=mumps_par%INFO(1:40) INFOG(1:40)=mumps_par%INFOG(1:40) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:40) = mumps_par%ICNTL(1:40) 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) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N 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 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.1.2/src/mumps_io_err.c0000664000175000017500000001035213164366240016365 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/src/cfac_scalings.F0000664000175000017500000002673413164366264016430 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), INFO(40) 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(OUT) :: 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.1.2/src/dfac_process_rtnelind.F0000664000175000017500000001066213164366263020173 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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,ND ) USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' 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) 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)), SLAVEF) 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, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, 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(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.1.2/src/zfac_front_LU_type2.F0000664000175000017500000006077413164366266017533 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'zmumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 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(40), 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), & 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)), NBPROCFILS(KEEP(28)), & 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 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 INTEGER PIVOT_OPTION, LAST_COL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER :: NOMP INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF NOMP=1 !$ NOMP=OMP_GET_MAX_THREADS() 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) IF (UUTEMP == 0.0D0 .AND. KEEP(201).NE.1) THEN ENDIF 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= .FALSE. NULLIFY(BEGS_BLR) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) 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 K263 = 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 IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 CNT_NODES = CNT_NODES + 1 CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL SYSTEM_CLOCK(TTOT1FR) ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 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 IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL ZMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW, & 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, & IPIV & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. & (KEEP(485).EQ.0) & ) & ) 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 CALL ZMUMPS_BUF_TEST() NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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, .FALSE., .TRUE., & .FALSE. ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF CALL ZMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 2, 0) ENDIF IF (LR_ACTIVATED) THEN NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 101 ENDIF END_I=NB_BLR ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP(470), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H', 2) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (K263.NE.0) 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR .LT. NASS) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, (PIVOT_OPTION.LT.2), .TRUE. & , (KEEP(377) .EQ. 1) & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF CALL SYSTEM_CLOCK(T1) IF (IEND_BLR.LT.NFRONT) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, .FALSE., .FALSE., & .FALSE. ) ENDIF CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_TRSM_TIME = LOC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR)) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & 0, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), BEGS_BLR(CURRENT_BLR+1), & NPARTSASS, BLR_L, CURRENT_BLR, 'V', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & NFRONT, KEEP(470), & END_I_IN=END_I & ) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) CALL DEALLOC_BLR_PANEL (BLR_L, NPARTSASS-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF (KEEP(201).EQ.1) 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 CALL STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, 0, INODE, & NELIM) CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_FLOP_FRONT_TYPE2(NFRONT, NASS, KEEP(50), & STEP_STATS(INODE), NELIM ) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 480 CONTINUE write(*,*) 'Allocation problem in BLR routine & ZMUMPS_FAC_FRONT_LU_TYPE2: ', & 'not enough memory? memory requested = ' , IERROR 490 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE DEALLOCATE( IPIV ) RETURN END SUBROUTINE ZMUMPS_FAC2_LU END MODULE ZMUMPS_FAC2_LU_M MUMPS_5.1.2/src/sfac_process_end_facto_slave.F0000664000175000017500000002365313164366263021513 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ) 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 #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) CALL SMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF), IFLAG, KEEP8, .TRUE.) IW(IOLDPS+XXS)=S_ALL 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, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG 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(70) = KEEP8(70) + MEM_GAIN KEEP8(71) = KEEP8(71) + MEM_GAIN CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) 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 IW(IOLDPS+XXS)=S_NOLCBCONTIG 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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, 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(70) = KEEP8(70) + MEM_GAIN KEEP8(71) = KEEP8(71) + 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/cmumps_save_restore_files.F0000664000175000017500000000071313164366265021106 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE CMUMPS_SAVE_FILES_RETURN MUMPS_5.1.2/src/cmumps_ooc_buffer.F0000664000175000017500000004247113164366265017343 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC_BUF_PANEL' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC_BUF_PANEL' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC_BUF_PANEL' 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.1.2/src/mumps_metis64.h0000664000175000017500000000263513164366240016413 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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); #endif #endif MUMPS_5.1.2/src/sfac_lastrtnelind.F0000664000175000017500000001742713164366262017345 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)),SLAVEF) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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( .FALSE.,MYID,N, IPOS_SON, & PTRAST(STEP(IN)), & 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.1.2/src/smumps_struc_def.F0000664000175000017500000000070613164366263017221 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/cfac_asm_ELT.F0000664000175000017500000001737113164366264016106 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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(8) :: POSELT 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)) POSELT = PTRAST(STEP(INODE)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS) END IF 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 END DO END IF 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) 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) 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 :: 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)) A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = ZERO NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) 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.1.2/src/dmumps_save_restore.F0000664000175000017500000000071713164366264017730 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_SAVE_RESTORE_RETURN() RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_RETURN MUMPS_5.1.2/src/zmumps_ooc_buffer.F0000664000175000017500000004252113164366266017367 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC_BUF_PANEL' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC_BUF_PANEL' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC_BUF_PANEL' 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.1.2/src/sfac_front_LU_type1.F0000664000175000017500000005044413164366263017511 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS & , LRGROUPS & ) 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 !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR, NOFFW, NPVW 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) 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 REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVOT_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 CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok INTEGER :: OMP_NUM INCLUDE 'mumps_headers.h' IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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) 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(BEGS_BLR) 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 (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 IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 PIVOT_OPTION = 4 CNT_NODES = CNT_NODES + 1 CALL INIT_STATS_FRONT(NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL INIT_STATS_FRONT(-NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1FR) ENDIF IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL SMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW, & 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 & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( (KEEP(201).EQ.1).AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. (.NOT. COMPRESS_PANEL) .OR. & (KEEP(485).EQ.0) & ) & ) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) END IF 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, .FALSE., .TRUE., & .FALSE. ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) END IF 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, (PIVOT_OPTION.LT.2), .TRUE., & .FALSE. ) ENDIF ELSE CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 1, 0) NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF CALL SYSTEM_CLOCK(T1) IF (IEND_BLR.LT.NFRONT .AND. PIVOT_OPTION.EQ.4) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & -66666, & A, LA, POSELT, .FALSE., .FALSE., & .FALSE. ) ENDIF CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_TRSM_TIME = LOC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR)) ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) IF (IFLAG.LT.0) GOTO 400 CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H', 1) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V', 1) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) END IF IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & . FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF (KEEP(201).EQ.1) 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 IF (COMPRESS_CB) THEN CALL SMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, NPARTSCB+NPARTSASS, & BEGS_BLR, NPARTSCB+NPARTSASS, NPARTSASS, & DKEEP(8), NASS, NFRONT-NASS, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, STEP_STATS(INODE), 1, & .FALSE., 0, KEEP(484)) ENDIF CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NFRONT-NASS, & KEEP(50), INODE, NASS-NPIV) CALL STATS_COMPUTE_FLOP_FRONT_TYPE1(NFRONT, NASS, NPIV, & KEEP(50), INODE) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) DEALLOCATE(WORK) DEALLOCATE(RWORK) DEALLOCATE(TAU) DEALLOCATE(JPVT) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF 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, LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 490 CONTINUE write(*,*) 'Allocation problem in BLR routine & SMUMPS_FAC_FRONT_LU_TYPE1: ', & 'not enough memory? memory requested = ' , IERROR 500 CONTINUE NPVW = NPVW + IW(IOLDPS+1+XSIZE) RETURN END SUBROUTINE SMUMPS_FAC1_LU END MODULE SMUMPS_FAC1_LU_M MUMPS_5.1.2/src/zfac_asm_master_ELT_m.F0000664000175000017500000016352713164366266020033 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,NBPROCFILS, 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 MUMPS_BUILD_SORT_INDEX_ELT_M USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N,LIW,NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS 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))) LOGICAL SON_LEVEL2 COMPLEX(kind=8), TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) 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 NBPROCFILS(KEEP(28)), NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INTEGER ETATASS LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE 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 INTEGER(8) NFRONT8, LAELL8 INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC INTEGER(8) LSTK8, SIZFR8 INTEGER SIZFI, NCB 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 NCOLS, NROWS, LDA_SON INTEGER NELIM, & IORG, IBROT 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, POINTER :: SON_IWPOS INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC 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 COMPRESSCB =.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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 LREQ_OOC = 0 IF (KEEP(201).EQ.1) 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) 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, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, 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)), & SLAVEF))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) 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 NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress ZMUMPS_FAC_ASM_NIV1_ELT' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) #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=3000 !$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 NUMROWS = NFRONT8 TOPDIAG = max(KEEP(7), KEEP(8), KEEP(57), KEEP(58))-1 !$ 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 NASS = NASS1 PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = SON_IW(ISTCHK + 3+KEEP(IXSZ)) 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 COMPRESSCB = & ( SON_IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( SON_IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF 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) THEN K2 = K1 + LSTK - 1 IF (COMPRESSCB) 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 SIZFR8 = int(NELIM,8) * int(NELIM,8) END IF K2 = K1 + NELIM - 1 ENDIF OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) 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) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR8 ELSE LCB = int(LDA_SON,8) * int(K2-K1+1,8) ENDIF IF (LCB .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB & ) 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(SSARBR, MYID, N, ISTCHK, & IACHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 END DO 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 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 280 CONTINUE INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING ZMUMPS_ASM_NIV1_ELT' ENDIF GOTO 500 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 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, & NBPROCFILS, 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(40) 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 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))) COMPLEX(kind=8) A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW 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 LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)), 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 INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 ETATASS 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(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 :: 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)) COMPRESSCB=.FALSE. ETATASS = 0 IN = INODE NBPROCFILS(STEP(IN)) = 0 NSTEPS = NSTEPS + 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)), & SLAVEF) .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) MAXFRW = max0(MAXFRW, NFRONT) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 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)), & SLAVEF) 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)), & SLAVEF) 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)), & SLAVEF) 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) 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) 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) 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) GOTO 275 CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, 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) 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) #if defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) IF ( KEEP(73) .EQ. 0 ) THEN #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 defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) ENDIF #endif #endif 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 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress ZMUMPS_FAC_ASM_NIV2_ELT' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), IW(IOLDPS+XXNBPR)) #endif 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 = max(int(KEEP(361)/2,8), !$ & (LAELL8+NOMP-1) / NOMP ) !$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 ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 !$ 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 + KEEP(IXSZ) + 3) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) 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) + 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) + A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (NSLSON.EQ.0) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF IF (LCB .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & COMPRESSCB & ) 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, & 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), & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 280 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, WORKSPACE TOO SMALL DURING ZMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) 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.1.2/src/zsol_root_parallel.F0000664000175000017500000000730213164366265017546 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), 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.1.2/src/zstatic_ptr_m.F0000664000175000017500000000177713164366265016534 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zmumps_load.F0000664000175000017500000065451413164366265016207 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) INTEGER, SAVE, PRIVATE :: NB_LEVEL2 LOGICAL, PRIVATE :: AMI_CHOSEN,IS_DISPLAYED #endif #endif #if ! defined(OLD_LOAD_MECHANISM) DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM #else DOUBLE PRECISION, SAVE, PRIVATE :: LAST_LOAD_SENT, & DM_LAST_MEM_SENT #endif 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 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, K66, & K375, MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER, INTENT(IN) :: K64, K66, K375 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(K66), 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 (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(40), & 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .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(40), & 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .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(40), & 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(40) 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 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 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 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)) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER(8), intent(in) :: MEMORY_MD_ARG INTEGER(8), intent(in) :: MAXS INTEGER K34_LOC,K35_LOC INTEGER allocok, IERR, i, BUF_LOAD_SIZE DOUBLE PRECISION :: MAX_SBTR DOUBLE PRECISION ZERO DOUBLE PRECISION MEMORY_SENT PARAMETER( ZERO=0.0d0 ) DOUBLE PRECISION SIZE_REAL(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 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 ) 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 #if ! defined(OLD_LOAD_MECHANISM) 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 #endif CHECK_MEM=0_8 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) NB_LEVEL2=0 AMI_CHOSEN=.FALSE. IS_DISPLAYED=.FALSE. #endif #endif 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) 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) 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) SBTR_PEAK_ARRAY=dble(0) IF (allocated(SBTR_CUR_ARRAY)) DEALLOCATE(SBTR_CUR_ARRAY) ALLOCATE(SBTR_CUR_ARRAY(id%NBSA_LOCAL),stat=allocok) 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_REAL(1),SIZE_REAL(2),K35_LOC) K35 = K35_LOC BUF_LOAD_SIZE = K34_LOC * 2 * ( NPROCS - 1 ) + & NPROCS * ( K35_LOC + K34_LOC ) IF (BDC_MEM) THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35_LOC END IF IF (BDC_SBTR)THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35_LOC 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 defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MYID ) = COST_SUBTREE LAST_LOAD_SENT = ZERO #endif IF ( BDC_MEM ) THEN DO i = 0, NPROCS - 1 DM_MEM( i )=ZERO END DO #if defined(OLD_LOAD_MECHANISM) DM_LAST_MEM_SENT=ZERO #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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 TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL ZMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE DOUBLE PRECISION INC_LOAD INTEGER KEEP(500) INTEGER(8) KEEP8(150) LOGICAL PROCESS_BANDE 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 ! defined(OLD_LOAD_MECHANISM) IF ( PROCESS_BANDE ) THEN RETURN ENDIF #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 #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = DELTA_LOAD + & (INC_LOAD-REMOVE_NODE_COST) GOTO 888 #else GOTO 888 #endif ELSE #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = DELTA_LOAD - & (REMOVE_NODE_COST-INC_LOAD) GOTO 888 #else GOTO 888 #endif ENDIF ENDIF GOTO 333 ENDIF #if ! defined(OLD_LOAD_MECHANISM) 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 #else 888 CONTINUE IF ( abs( LOAD_FLOPS ( MYID ) - & LAST_LOAD_SENT ).GT.MIN_DIFF)THEN IERR = 0 SEND_LOAD = LOAD_FLOPS( MYID ) IF ( BDC_MEM ) THEN SEND_MEM = DM_MEM(MYID) ELSE SEND_MEM = ZERO END IF #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_UPDATE",IERR CALL MUMPS_ABORT() ENDIF IF ( IERR .EQ. 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = ZERO IF (BDC_MEM) DELTA_MEM = ZERO #else LAST_LOAD_SENT = LOAD_FLOPS( MYID ) IF ( BDC_MEM ) DM_LAST_MEM_SENT = DM_MEM( MYID ) #endif END IF 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 #if defined(OLD_LOAD_MECHANISM) DOUBLE PRECISION TMP_MEM #endif IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN PROCESS_BANDE=PROCESS_BANDE_ARG INC_MEM = INC_MEM_ARG #if ! defined(OLD_LOAD_MECHANISM) 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 #endif #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) IF(PROCESS_BANDE)THEN PROCESS_BANDE=.FALSE. NB_LEVEL2=NB_LEVEL2-1 IF(NB_LEVEL2.LT.0)THEN WRITE(*,*)MYID,': problem with NB_LEVEL2' ELSEIF(NB_LEVEL2.EQ.0)THEN IF(IS_DISPLAYED)THEN IS_DISPLAYED=.FALSE. ENDIF AMI_CHOSEN=.FALSE. ENDIF ENDIF IF((KEEP(73).EQ.0).AND.(NB_LEVEL2.NE.0) & .AND.(.NOT.IS_DISPLAYED))THEN IS_DISPLAYED=.TRUE. ENDIF #endif #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 ! defined(OLD_LOAD_MECHANISM) IF (PROCESS_BANDE) THEN RETURN ENDIF #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 defined(OLD_LOAD_MECHANISM) IF(KEEP_LOAD(201).EQ.0)THEN DM_MEM( MYID ) = dble(CHECK_MEM) - DM_SUMLU ELSE DM_MEM( MYID ) = dble(CHECK_MEM) ENDIF TMP_MEM = DM_MEM(MYID) #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 ! defined(OLD_LOAD_MECHANISM) 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 #else IF(BDC_M2_MEM.AND.REMOVE_NODE_FLAG_MEM)THEN IF(INC_MEM.NE.REMOVE_NODE_COST_MEM)THEN IF(INC_MEM.EQ.REMOVE_NODE_COST_MEM)THEN GOTO 333 ELSEIF(INC_MEM.LT.REMOVE_NODE_COST_MEM)THEN GOTO 333 ENDIF ENDIF ENDIF IF ((KEEP(48).NE.5).OR. & ((KEEP(48).EQ.5).AND. & (abs(TMP_MEM-DM_LAST_MEM_SENT).GE. & 0.2d0*dble(LRLUS))))THEN IF ( abs( TMP_MEM-DM_LAST_MEM_SENT) > & DM_THRES_MEM ) THEN IERR = 0 SEND_MEM = TMP_MEM #endif 111 CONTINUE CALL ZMUMPS_BUF_SEND_UPDATE_LOAD( & BDC_SBTR, & BDC_MEM,BDC_MD, COMM_LD, & NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & DELTA_LOAD, #else & LOAD_FLOPS( MYID ), #endif & SEND_MEM,SBTR_TMP, & DM_SUMLU, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_MEM_UPDATE",IERR CALL MUMPS_ABORT() ENDIF IF ( IERR .EQ. 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = ZERO DELTA_MEM = ZERO #else LAST_LOAD_SENT = LOAD_FLOPS ( MYID ) DM_LAST_MEM_SENT = TMP_MEM #endif END IF 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 ) #if ! defined(OLD_LOAD_MECHANISM) DEALLOCATE(FUTURE_NIV2) #endif 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 IERR, MSGTAG, MSGLEN, MSGSOU,COMM INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL FLAG 10 CONTINUE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) 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) 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) 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 ) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE INTEGER MSGSOU, LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INCLUDE 'mpif.h' INTEGER POSITION, IERR, WHAT, NSLAVES, i 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 ) IF ( WHAT == 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) #else #endif CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR ) #if ! defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED #else LOAD_FLOPS( MSGSOU ) = LOAD_RECEIVED #endif IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR ) #if ! defined(OLD_LOAD_MECHANISM) DM_MEM(MSGSOU) = DM_MEM(MSGSOU) + LOAD_RECEIVED #else DM_MEM(MSGSOU) = LOAD_RECEIVED #endif 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 ) 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 ) 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) WRITE(*,*)MYID,':Receiving M2A from',MSGSOU i=1 DO WHILE ((i.LE.NSLAVES).AND.(LIST_SLAVES(i).NE.MYID)) i=i+1 ENDDO IF(i.LT.(NSLAVES+1))THEN NB_LEVEL2=NB_LEVEL2+1 WRITE(*,*)MYID,':NB_LEVEL2=',NB_LEVEL2 AMI_CHOSEN=.TRUE. IF(KEEP_LOAD(73).EQ.1)THEN IF(.NOT.IS_DISPLAYED)THEN WRITE(*,*)MYID,': Begin of Incoherent state (2) at time=', & MPI_WTIME()-TIME_REF IS_DISPLAYED=.TRUE. ENDIF ENDIF ENDIF IF(KEEP_LOAD(73).EQ.1) GOTO 344 #endif #endif DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif LOAD_FLOPS(LIST_SLAVES(i)) = & LOAD_FLOPS(LIST_SLAVES(i)) + & LOAD_INCR(i) #if defined(OLD_LOAD_MECHANISM) END IF #endif END DO IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif 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))) #if defined(OLD_LOAD_MECHANISM) END IF #endif 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) 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 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) 344 CONTINUE #endif #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 ) 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 ) SBTR_MEM(MSGSOU)=SBTR_MEM(MSGSOU)+LOAD_RECEIVED #if ! defined(OLD_LOAD_MECHANISM) 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 ) MD_MEM(MSGSOU)=999999999_8 TAB_MAXS(MSGSOU)=TAB_MAXS(MSGSOU)+int(SURF,8) ENDIF #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 ) 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR ) IF( & MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE_RECEIVED)), & NPROCS).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 ) 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 ) 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 ) IF(BDC_MD)THEN #if ! defined(OLD_LOAD_MECHANISM) DM_MEM(MYID)=DM_MEM(MYID)+LOAD_RECEIVED #else DM_MEM(MYID)=LOAD_RECEIVED #endif 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 ) #if ! defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED #else LOAD_FLOPS( MSGSOU ) = LOAD_RECEIVED #endif 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif MD_MEM(LIST_SLAVES(i)) = & MD_MEM(LIST_SLAVES(i)) + & int(LOAD_INCR(i),8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(LIST_SLAVES(i)+1).EQ.0)THEN MD_MEM(LIST_SLAVES(i))=999999999_8 ENDIF #endif #if defined(OLD_LOAD_MECHANISM) END IF #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 ) MD_MEM(MSGSOU)=MD_MEM(MSGSOU)+int(LOAD_RECEIVED,8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(MSGSOU+1).EQ.0)THEN MD_MEM(MSGSOU)=999999999_8 ENDIF #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 ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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 #if ! defined(OLD_LOAD_MECHANISM) #if ! defined(IBC_TEST) 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) GOTO 112 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 #endif #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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif 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 #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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)), SLAVEF ) 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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) GOTO 111 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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)), NPROCS) & ) THEN RETURN ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE_LOAD(STEP_LOAD(INODE)),NPROCS))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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0), & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0), MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 112 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 CONTINUE 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) IF (WLOAD(i) < -0.5d0 ) THEN IF((MP.GT.0).AND.(LP.GE.2))THEN WRITE(MP,*)MYID,': Warning: negative load ', & WLOAD(i) ENDIF ENDIF 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)), & SLAVEF))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)), NPROCS ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL 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 #if ! defined(OLD_LOAD_MECHANISM) TO_BE_SENT=DELTA_LOAD-COST DELTA_LOAD=dble(0) #else TO_BE_SENT=LAST_LOAD_SENT-COST LAST_LOAD_SENT=LAST_LOAD_SENT-COST #endif 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 #if ! defined(OLD_LOAD_MECHANISM) DELTA_MEM=DELTA_MEM+TMP_M2 TO_BE_SENT=DELTA_MEM #else TO_BE_SENT=DM_LAST_MEM_SENT+TMP_M2 DM_LAST_MEM_SENT=DM_LAST_MEM_SENT+TMP_M2 #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, & TO_BE_SENT, & MYID, KEEP_LOAD, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF 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 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)), & SLAVEF)) THEN RETURN ENDIF FATHER=MUMPS_PROCNODE(PROCNODE(STEP(FATHER_NODE)),SLAVEF) 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)), & NPROCS).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) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_UPPER_PREDICT", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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)), NPROCS ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error 2 in ZMUMPS_LOAD_SEND_MD_INFO", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif DO i = 1, NP_TO_UPDATE MD_MEM(P_TO_UPDATE(i))=MD_MEM(P_TO_UPDATE(i))+ & int(DELTA_MD( i ),8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(P_TO_UPDATE(i)+1).EQ.0)THEN MD_MEM(P_TO_UPDATE(i))=999999999_8 ENDIF #endif ENDDO #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif DEALLOCATE(DELTA_MD,P_TO_UPDATE,IPROC2POSINDELTAMD) 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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)),NPROCS).EQ.MYID)THEN IF(INODE.EQ.KEEP_LOAD(38))THEN GOTO 666 #if ! defined(OLD_LOAD_MECHANISM) ELSE IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': i did not find ',SON CALL MUMPS_ABORT() ENDIF GOTO 666 #endif 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 defined(NOT_ATM_POOL_SPECIAL) DOUBLE PRECISION TMP #endif IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0) & .AND.(INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF #if defined(NOT_ATM_POOL_SPECIAL) IF((INODE.LT.0).OR.(INODE.GT.N_LOAD))THEN MAX_MEM=huge(MAX_MEM) DO i=0,NPROCS-1 TMP=dble(TAB_MAXS(i))-(DM_MEM(i)+LU_USAGE(i)) IF(BDC_SBTR)THEN TMP=TMP-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF MAX_MEM=min(MAX_MEM,TMP) ENDDO RETURN ENDIF #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)), & NPROCS).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)), & NPROCS).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 ! defined(OLD_LOAD_MECHANISM) 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 #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)),NPROCS).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 #if defined(NOT_ATM_POOL_SPECIAL) IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N_LOAD ) THEN NODE = POOL(LPOOL-2-J) - N_LOAD ELSE NODE = POOL(LPOOL-2-J) ENDIF #else NODE=POOL(LPOOL-2-J) #endif 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)),NPROCS).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))), & NPROCS)) 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 MUMPS_5.1.2/src/sana_aux_ELT.F0000664000175000017500000010673013164366262016145 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) 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(40) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(40), 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) 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, 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, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS 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 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF OPTIONS_METIS(1) = 0 #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 OPT_METIS_SIZE = OPT_METIS_SIZE + 60 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE RETURN ENDIF CALL METIS_SETDEFAULTOPTIONS(OPTIONS_METIS) OPTIONS_METIS(18) = 1 #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(1), #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG(1), #endif & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2(1), #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG(1), #endif & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), & LP, LPOK, KEEP(10) ) 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) #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), & KEEP(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 CALL SMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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 CALL SMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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, I8, 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(40) 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( 40 ) 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 TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), SLAVEF ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .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 ) IMPLICIT NONE INTEGER N, NELT, SLAVEF INTEGER PROCNODE( N ), ELTPROC( NELT ) INTEGER ELT, I, ITYPE, MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),SLAVEF) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),SLAVEF) ELSE IF (ITYPE.EQ.2) 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.1.2/src/zana_driver.F0000664000175000017500000050145613164366266016156 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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, FILS, FRERE, NFSIZ INTEGER NE, NA INTEGER I, allocok INTEGER MAXIS1_CHECK 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, SBUF_REC, 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 C to store the size of the sequencial peak of stack C (or an estimation for not calling REORDER_TREE_N ) DOUBLE PRECISION PEAK C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, DIMENSION(:) :: PAR2_NODES 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_STAT INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED 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 INTEGER, POINTER, DIMENSION(:) :: WORK1PTR, WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR ! Used because of multithreaded SIM_NP_ INTEGER :: locMYID, locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER(kind=8) :: N8, NZ8, LIW8 INTEGER :: LIW_ELT 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 KEEP8(24) = 0_8 ! reinitialize last used size of WK_USER KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) 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 ---------------------------------------- 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 (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) 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 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) C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ) 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 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ---------------------------------------------- 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 ( associated(id%MEM_DIST) ) deallocate( id%MEM_DIST ) 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 ) RETURN 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 ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( KEEP(54) .eq. 3 ) THEN C ----------------------------------------------- C Collect on the host -- if matrix is distributed C at analysis -- all integer information. C ----------------------------------------------- CALL ZMUMPS_GATHER_MATRIX(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN END IF C ************************************************ C BEGINNING OF MASTER CODE FOR SEQUENTIAL ANALYSIS C ************************************************ 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. Done before 1234 label in order to avoid C two allocations of size 1 and a memory leak in case C there are two passes (see 1234 label below and C "GOTO 1234" statement) 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 in Schur ' CALL MUMPS_ABORT() END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF 1234 CONTINUE IF ( ( (KEEP(23) .NE. 0) .AND. & ( (KEEP(23).NE.7) .OR. KEEP(50).EQ. 2 ) ) & .OR. & ( associated(id%A) .AND. KEEP(52) .EQ. 77 .AND. & (KEEP(50).EQ.2)) & .OR. & KEEP(52) .EQ. -2 ) THEN C MAXIMUM TRANSVERSAL ALGORITHM called on original matrix. C KEEP(23) = 7 means that automatic choice C of max trans value will be done during Analysis. C We compute a permutation of the original matrix to have zero free diagonal C the col. Permutation is held in IS1(1, ...,N). C Max-trans (ZMUMPS_ANA_O) is not used for element entry. IF (.not.associated(id%A)) THEN C -- If maxtrans is required and A not allocated then reset C -- it to structural based maxtrans. IF (KEEP(23).GT.2) KEEP(23) = 1 ENDIF CALL ZMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%IS1(1), id, & ICNTL(1), INFO(1)) IF (INFO(1) .LT. 0) THEN C ----------- C Fatal error C ----------- C Permutation was not computed; reset keep(23) KEEP(23) = 0 GOTO 10 END IF END IF C END OF MAX-TRANS ON THE MASTER C C ********************************************************** C C BEGINNING OF ANALYSIS, STILL ON THE MASTER C C Set up subdivisions of arrays for analysis C C ------------------------------------------------------ C Define the size of a working array C that will be used as workspace ZMUMPS_ANA_F. 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 N8=int(id%N,8) IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=int(id%KEEP8(28),8) IF ( KEEP(256) .EQ. 1 ) THEN ! KEEP(256) <-- ICNTL(7) LIW8 = 2_8 * NZ8 + N8 + 1_8 ELSE LIW8 = 2_8 * NZ8 + N8 + 1_8 ENDIF 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*N8) LIW8 = 3_8*N8 ELSE IF (LIW_ELT.LT.3*id%N) LIW_ELT = 3*id%N ENDIF IF (KEEP(23) .NE. 0) THEN IKEEP = id%N + 1 ELSE IKEEP = 1 END IF NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N MAXIS1_CHECK = NFSIZ + id%N - 1 C C ANALYSIS PHASE C Some workspace of ZMUMPS_ANA_F can be reused in subsequent phases. C IS(IKEEP) OF LENGTH 3*N C IS(NFSIZ) OF LENGTH N holds the frontal matrix sizes C IS(FILS) and IS(FRERE) OF LENGTH N holds the assembly tree C IF ( KEEP(256) .EQ. 1 ) THEN C Note that id%PERM_IN has been checked before. DO I = 1, id%N id%IS1( IKEEP + I - 1 ) = id%PERM_IN( I ) END DO 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 CALL ZMUMPS_ANA_F(id%N, id%KEEP8(28), & id%IRN(1), id%JCN(1), & LIW8, id%IS1(IKEEP), & KEEP(256), id%IS1(NFSIZ), & id%IS1(FILS), id%IS1(FRERE), & id%LISTVAR_SCHUR(1), SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1),id%NSLAVES, & id%IS1(1),id) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max trans KEEP(23) = -KEEP(23) IF (.NOT. associated(id%A)) KEEP(23) = 1 GOTO 1234 ENDIF INFOG(7) = KEEP(256) 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, & id%IS1(IKEEP), & KEEP(256), id%IS1(NFSIZ), id%IS1(FILS), & id%IS1(FRERE), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1)) 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 ) 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) C Check error during ZMUMPS_ANA_F OR ZMUMPS_ANA_F_ELT IF ( INFO(1) .LT. 0 ) THEN GO TO 10 ENDIF ENDIF ELSE C Parallel analysis IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N IF (id%MYID .EQ. MASTER) THEN C this correspond to the old PTRAR part of IS1 C WORK2PTR => id%IS1(PTRAR : PTRAR + 4*id%N-1) ALLOCATE(WORK2PTR(4*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(WORK1PTR(3*id%N),WORK2PTR(4*id%N), stat=IERR ) ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN INFO( 2 ) = 4*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 ) RETURN IF(id%MYID .EQ. MASTER) THEN WORK1PTR => id%IS1(IKEEP : IKEEP + 3*id%N-1) NFSIZPTR => id%IS1(NFSIZ : NFSIZ + id%N-1) FILSPTR => id%IS1(FILS : FILS + id%N-1) FREREPTR => id%IS1(FRERE : FRERE + id%N-1) END IF CALL ZMUMPS_ANA_F_PAR(id, & WORK1PTR, & WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR) DEALLOCATE(WORK2PTR) IF(id%MYID .EQ. 0) THEN NULLIFY(WORK1PTR, NFSIZPTR) NULLIFY(FILSPTR, FREREPTR) ELSE DEALLOCATE(WORK1PTR) END IF KEEP(28) = INFOG(6) END IF 10 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN 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(id%N, id%IS1(FILS), id%IS1(FRERE), & id%IS1(NE), id%IS1(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 id%KEEP(20)=0 id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C id%PROCNODE = 0 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 CALL ZMUMPS_SET_PROCNODE(id%KEEP(38), id%PROCNODE(1), & 1+2*id%NSLAVES, id%IS1(FILS),id%N) 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 => id%IS1(IKEEP:IKEEP+id%N-1) C Map nodes and assign candidates for dynamic scheduling CALL ZMUMPS_DIST_AVOID_COPIES(id%N,id%NSLAVES,ICNTL(1), & INFOG(1), & id%IS1(NE), & id%IS1(NFSIZ), & id%IS1(FRERE), & id%IS1(FILS), & KEEP(1),KEEP8(1),id%PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & ) 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(id%N, id%IS1(FILS), & id%IS1(FRERE), id%IS1(NE), & id%IS1(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN 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) ) 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 ) RETURN 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, id%IS1(FRERE), & id%IS1(FILS), & id%IS1(IKEEP+id%N), id%IS1(IKEEP+2*id%N), 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 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 numbers. C This is used later in the initial elemental C matrix distribution at the beginning of the factorisation phase C --------------------------------------- CALL ZMUMPS_ELTPROC(id%N, NELT, id%ELTPROC(1),id%NSLAVES, & id%PROCNODE(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, id%N IF ( ( id%IS1(FRERE+INODE-1) .NE. id%N+1 ) .AND. & ( MUMPS_TYPENODE(id%PROCNODE(INODE),id%NSLAVES) & .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 * =============================== * ! blocking factor for multiple RHS for ana_distm KEEP(84) = ICNTL(27) END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. 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 MUMPS_BCAST_I8( id%KEEP8(21), MASTER, & id%MYID, 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 ----------------- C Broadcast LR related keep informations KEEP(483-492) C if includes MPI_BCAST(idKEEP(486) CALL MPI_BCAST( id%KEEP(483), 10, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Save setting (used later during factorization) C to enable BLR KEEP(494) = KEEP(486) 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 C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) 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 CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 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 CALL MUMPS_REALLOC(id%LRGROUPS, id%N, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. IF ( associated( id%UNS_PERM ) ) deallocate(id%UNS_PERM) C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID == MASTER .AND. id%KEEP(23) .NE. 0 ) THEN C This one is only on the master allocate(id%UNS_PERM(id%N),stat=allocok) IF ( allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = id%N IF ( LPOK ) THEN WRITE(LP, 150) 'id%UNS_PERM' END IF GOTO 94 ENDIF C DO I=1,id%N id%UNS_PERM(I) = id%IS1(I) END DO ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN DO I=1,id%N id%FILS(I) = id%IS1(FILS+I-1) ENDDO END IF 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 (id%N.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (id%IS1(NA+id%N-1) .LT.0) THEN NBLEAF = id%N NBROOT = id%N ELSE IF (id%IS1(NA+id%N-2) .LT.0) THEN NBLEAF = id%N-1 NBROOT = id%IS1(NA+id%N-1) ELSE NBLEAF = id%IS1(NA+id%N-2) NBROOT = id%IS1(NA+id%N-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) IF(INFO(1).LT.0) GOTO 96 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 ( id%N == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (id%IS1(NA+id%N-1) < 0) THEN id%NA(LEAF) = - id%IS1(NA+id%N-1)-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO ELSE IF (id%IS1(NA+id%N-2) < 0 ) THEN INODE = - id%IS1(NA+id%N-2) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = id%IS1(NA+I-1) LEAF = LEAF + 1 ENDDO END IF END IF 96 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF ( id%MYID .EQ. MASTER ) THEN 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, id%N IF ( id%IS1(FRERE+I-1) .ne. id%N + 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 = id%IS1(FILS+I-1) DO WHILE ( INN .GT. 0 ) id%STEP(INN) = - ISTEP INN = id%IS1(FILS + INN -1) END DO IF (id%IS1(FRERE+I-1) .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' CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ DO I = 1, id%N IF (id%IS1(FRERE+I-1) .NE. id%N+1) THEN id%PROCNODE_STEPS(id%STEP(I)) = id%PROCNODE( I ) id%FRERE_STEPS(id%STEP(I)) = id%IS1(FRERE+I-1) id%NE_STEPS(id%STEP(I)) = id%IS1(NE+I-1) id%ND_STEPS(id%STEP(I)) = id%IS1(NFSIZ+I-1) ENDIF ENDDO C =============================== C Algoritme 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, id%N C -- skip non principal nodes IF ( id%STEP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (id%IS1(FRERE+I-1) .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 = id%IS1(FILS+I-1) DO WHILE ( IFS .GT. 0 ) IFS= id%IS1(FILS + IFS -1) 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 = id%IS1(FRERE+IFS-1) ENDDO END DO C C C Following arrays (PROCNODE and IS1) not used anymore C during analysis DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) DEALLOCATE(id%IS1) NULLIFY(id%IS1) 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. 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%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 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 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%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 C Compute a grouping of variables for LR approximations. C id%SYM_PERM is used as a work array IF(KEEP(486) .EQ. 1) THEN IF ( (KEEP(54).eq.3) .AND. (KEEP(244).eq.2) ) THEN C If the input matrix is distributed and the parallel analysis is C chosen, the graph has to be centralized in order to compute the C clustering. CALL ZMUMPS_GATHER_MATRIX(id) END IF IF (KEEP(469).EQ.0) THEN CALL ZMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN(1), & id%JCN(1), id%FILS(1), id%FRERE_STEPS(1), & id%DAD_STEPS(1), id%NE_STEPS(1), id%STEP(1), id%NA(1), & id%LNA, id%LRGROUPS(1), & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), id%KEEP(489), & 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), LPOK, LP) ELSE CALL ZMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN(1), & id%JCN(1), id%FILS(1), id%FRERE_STEPS(1), & id%DAD_STEPS(1), id%NE_STEPS(1), id%STEP(1), id%NA(1), & id%LNA, id%LRGROUPS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), id%KEEP(489), & 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), LPOK, LP) ENDIF IF ( (KEEP(54).eq.3) .AND. (KEEP(244).eq.2) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above deallocate(id%IRN, id%JCN) NULLIFY(id%IRN) NULLIFY(id%JCN) END IF END IF CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 80 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%INFO(1) ) ELSE ! matches the IF (id%MYID .EQ. MASTER) THEN ... above CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 80 IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2) & .AND. (abs(KEEP(486)).EQ.1)) THEN C If the input matrix is distributed and the parallel analysis is C chosen, the graph has to be centralized in order to compute the C clustering. CALL ZMUMPS_GATHER_MATRIX(id) END IF ENDIF C Root principal variable C for scalapack (KEEP(38)) might have been updated C since root variables might have been permuted. C It should thus be redistributed to all procs IF((abs(KEEP(486)) .EQ. 1).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 ) RETURN 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(486).EQ.1) 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_PAR, 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_PAR(id, id%PTRAR(1)) 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 DEALLOCATE( id%IRN ) DEALLOCATE( id%JCN ) 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)) & deallocate(id%DEPTH_FIRST) 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)) * DEALLOCATE(id%DEPTH_FIRST_SEQ) 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)) * DEALLOCATE(id%SBTR_ID) 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)) & deallocate(id%DEPTH_FIRST) 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)) * DEALLOCATE(id%DEPTH_FIRST_SEQ) 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)) * DEALLOCATE(id%SBTR_ID) 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)) & deallocate(id%COST_TRAV) 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)) & deallocate(id%COST_TRAV) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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)) & deallocate(id%MEM_SUBTREE) 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)) & deallocate(id%MY_ROOT_SBTR) 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)) & deallocate(id%MY_FIRST_LEAF) 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)) & deallocate(id%MY_NB_LEAF) 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 ) RETURN 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)) deallocate(id%CANDIDATES) 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 ) RETURN 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 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 ! defined(OLD_LOAD_MECHANISM) 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%NSLAVES) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO #endif 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 ) RETURN C ------------------------------ C Perform again the subdivision of array C IS1, both on the master and on C the slaves. This is done so to C ease the passage to the model C where master will work. C ------------------------------ C IF ( KEEP(23).NE.0 .and. id%MYID .EQ. MASTER ) THEN IKEEP = id%N + 1 ELSE IKEEP = 1 END IF FILS = IKEEP + 3 * id%N NE = IKEEP + 2 * id%N NA = IKEEP + id%N FRERE = FILS + id%N NFSIZ = FRERE + id%N 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 ) RETURN IF ( I_AM_SLAVE ) THEN 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 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 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 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)) ENDIF CALL ZMUMPS_ANA_DISTM( locMYID_NODES, id%N, & id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), id%DAD_STEPS(1), & id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, & KEEP8(11), KEEP(26), KEEP(15), & KEEP8(12), ! formerly KEEP(16), & KEEP8(14), ! formerly KEEP(200), & KEEP(224), KEEP(225), & KEEP(27), RINFO(1), & KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, SBUF_RECOLD8, & SBUF_SEND, SBUF_REC, 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(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) + 2* 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) + 2* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) C size of S KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) C size of S KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /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 = max(SBUF_SEND,KEEP(27)) SBUF_REC = max(SBUF_REC ,KEEP(27)) CALL MPI_ALLREDUCE (SBUF_REC, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43)=KEEP(44) ELSE KEEP(43)=SBUF_SEND 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(43) = max(KEEP(43), 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 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 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0D0 END IF 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 -------------------------------------- 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) CALL MUMPS_REDUCEI8( KEEP8(11), KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) C -------------- C Flops estimate C -------------- CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_DOUBLE_PRECISION, MPI_SUM, & id%COMM, IERR) 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) ) 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 IN-CORE MEMORY STATISTICS C ========================= OOC_STAT = KEEP(201) IF (KEEP(201) .NE. -1) OOC_STAT=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_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(2) = TOTAL_BYTES 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_STAT, PERLU_ON, TOTAL_BYTES) IF ( PROK ) THEN WRITE(MP,'(A,I10) ') & ' Estimated space in MBYTES for IC factorization :', & 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 WRITE( MPG,'(A,I16) ') & ' ** Rank of proc needing largest memory in IC facto :', & IRANK WRITE( MPG,'(A,I16) ') & ' ** Estimated corresponding MBYTES for IC facto :', & id%INFOG(16) IF ( KEEP(46) .eq. 0 ) THEN C Host not working WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,(id%INFOG(17)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,id%INFOG(17)/id%NSLAVES END IF WRITE(MPG,'(A,I16) ') & ' ** TOTAL space in MBYTES for IC factorization :' & ,id%INFOG(17) END IF C ========================================= C NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS C (except when OOC_STAT is equal to -1 in C which case IC and OOC statistics are C identical) C ========================================= OOC_STAT = KEEP(201) #if defined(OLD_OOC_NOPANEL) IF (OOC_STAT .NE. -1) OOC_STAT=2 #else IF (OOC_STAT .NE. -1) OOC_STAT=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_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(3) = TOTAL_BYTES 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_STAT, PERLU_ON, TOTAL_BYTES) id%INFO(17) = TOTAL_MBYTES CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I16) ') & ' ** Rank of proc needing largest memory for OOC facto :', & IRANK WRITE( MPG,'(A,I16) ') & ' ** Estimated corresponding MBYTES for OOC facto :', & id%INFOG(26) IF ( KEEP(46) .eq. 0 ) THEN C Host not working WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,(id%INFOG(27)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I16) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,id%INFOG(27)/id%NSLAVES END IF WRITE(MPG,'(A,I16) ') & ' ** TOTAL space in MBYTES for OOC factorization :' & ,id%INFOG(27) END IF c #endif 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)) & deallocate( id%MAPPING) 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 CALL ZMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & id%IRN(1),id%JCN(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 ) RETURN KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 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 Fwd in facto 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 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 IF ( PROKG ) THEN WRITE(MPG, '(A)') & ' Resetting candidate strategy to 0 because NSLAVES=1' WRITE(MPG, '(A)') ' ' END IF 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 IF ( PROKG ) THEN WRITE(MPG, '(A)') & ' Resetting candidate strategy to 8 ' WRITE(MPG, '(A)') ' ' END IF 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 ---------------------------- 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 kept for backward compatibility.' 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 * * Graph modification prior to ordering (id%ICNTL(12) option) * id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) * id%KEEP(95) = id%ICNTL(12) 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) = 0 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 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) = 7 C still forbid max trans for LLT IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not compatible with LLT 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 compatible with LLT 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).NE.0) 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 id%KEEP(95) = 1 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans 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)') & ' ** Max-trans not allowed because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN C Only Ruiz & Bora scaling available for dist format C (Work supported by ANR-SOLSTICE (ANR-06-CIS6-010)) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed (matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(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)') & ' ** Max-trans not allowed for element matrix' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling not allowed at analysis for element matrix' 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(39).NE.1 .and. id%ICNTL(39).NE.2) 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(39) 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(16) (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 -- Block low rank input parameter checking id%KEEP(486) = id%ICNTL(35) C KEEP(486)!=0,1 => KEEP(486)=0 IF (id%KEEP(486).NE.1) id%KEEP(486) = 0 IF(id%KEEP(486).NE.0) THEN C tests that may switch off BLR C C LR is incompatible with elemental matrices IF (id%KEEP(55).NE.0) THEN IF (PROK) WRITE(MP,*) & "WARNING: BLR feature currently incompatible " & ,"with elemental matrices" C Switch off BLR id%KEEP(486)=0 ENDIF C C LR incompatible with forward in facto in facto IF (id%KEEP(252).NE.0) THEN IF (PROK) WRITE(MP,*) & "WARNING: BLR feature currently incompatible " & ,"with forward during factorization" C Switch off BLR id%KEEP(486)=0 ENDIF IF((id%KEEP(492).EQ.0)) THEN id%KEEP(486)=0 ENDIF ENDIF C IF(id%KEEP(486).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(470)=0 or 1 IF ((id%KEEP(470).NE.0).AND.(id%KEEP(470).NE.1)) THEN id%KEEP(470)=1 ENDIF 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(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(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=4 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 IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 write(*,*) 'KEEP(480) = 0 => Resetting KEEP(474) to 0' ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 write(*,*) 'KEEP(480) < 4 => Resetting KEEP(478) to 0' ENDIF C In LUA strategy KEEP(480)>=5, we exploit LRTRSM to further C reduce the flops. It requires KEEP(475)>=2. 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 IF (id%KEEP(474).EQ.3) THEN write(*,*) 'KEEP(480) = ',id%KEEP(480), & ' and KEEP(474) = 3 ', & 'requires KEEP(475) >= 2, but it is = ', id%KEEP(475) ELSE write(*,*) 'KEEP(480) = ',id%KEEP(480), & 'requires KEEP(475) >= 2, but it is = ', id%KEEP(475) ENDIF 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 C id%KEEP(481)=0,1,2 IF ((id%KEEP(481).GT.2).OR.(id%KEEP(481).LT.0)) THEN id%KEEP(481)=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 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(485)>0 IF((id%KEEP(485).LT.0)) THEN id%KEEP(485)= 1 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(489)=0 or 1 IF ((id%KEEP(489).NE.0).AND.(id%KEEP(489).NE.1)) THEN id%KEEP(489)=0 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 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' TYPE(ZMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: MASTER, IERR, INDX INTEGER :: STATUS(MPI_STATUS_SIZE) 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 PARAMETER( MASTER = 0 ) 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 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 GOTO 13 ENDIF 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)/20_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, opens a file and dumps the matrix and/or C the right hand side. This subroutine calls C ZMUMPS_DUMP_MATRIX and ZMUMPS_DUMP_RHS. C The routine should be called on all processors. C INCLUDE 'mpif.h' C Arguments C ========= TYPE(ZMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED INTEGER :: MM_WRITE INTEGER :: MM_WRITE_CHECK CHARACTER(LEN=20) :: MM_IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER 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) 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 (id%WRITE_PROBLEM(1:20) .NE. "NAME_NOT_INITIALIZED")THEN 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 CLOSE(IUNIT) ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN C ===================== C Matrix is distributed C ===================== IF (id%WRITE_PROBLEM(1:20) .EQ. "NAME_NOT_INITIALIZED" & .OR. .NOT. I_AM_SLAVE )THEN MM_WRITE = 0 ELSE MM_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(MM_WRITE, MM_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 (MM_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(MM_IDSTR,'(I9)') id%MYID_NODES OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(MM_IDSTR))) CALL ZMUMPS_DUMP_MATRIX(id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL ) ! Elemental or not CLOSE(IUNIT) ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. & id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED")THEN OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL ZMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE ZMUMPS_DUMP_PROBLEM SUBROUTINE ZMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL ) 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 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)) 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)) 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)) 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)) 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" WRITE(IUNIT,*) id%A_ELT(:) 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, K, LD_RHS 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_RHS = id%N ELSE LD_RHS = id%LRHS ENDIF DO J = 1, id%NRHS DO I = 1, id%N K=(J-1)*LD_RHS+I WRITE(IUNIT,*) dble(id%RHS(K)), aimag(id%RHS(K)) 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 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, K489, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & LPOK, LP) USE ZMUMPS_ANA_LR C This routine is meant to compute a grouping of the variables in C all the separators. This grouping defines the blocks that will C be compressed by means of low-rank approximations. Because the C principal variables of all separators will be changed, it is C necessary to update the arrays FILS, FRERE_STEPS, DAD_STEPS, STEP, C NA. C C N - the size of the input matrix C NZ8 - the nnz in the input matrix C NSTEPS - the numbers of nodes in the tree C IRN - the row indices of the input matrix C JCN - the col indices of the input matrix C FILS - the fils array of size N. This array will be C modified on output according to the new relative C order computed for the variables in the separators C FRERE_STEPS - the FRERE_STEPS array. Modified on output (as for FILS) C DAD_STEPS - the DAD_STEPS array. Modified on output (as for FILS) C NE_STEPS - the NE_STEPS array. Modified on output (as for FILS) C STEP - the STEP array. Modified on output (as for FILS) C NA - the NA array. Modified on output (as for FILS) C LNA - The length of the NA array C LRGROUPS - the array mapping variables onto groups. C LRGROUPS(i)=k means that variable i belongs to C group k C SYM - the type of matrix (KEEP(50)) C ICNTL - the ICNTL array C HALO_DEPTH - the depth of the halo around the separator subgraph C GROUP_SIZE - the size of variables groups in the separators C K489 - BLR strategy (=3 compress CB) C SEP_SIZE - the minimum size of a separator to be treated with C low-rank approximations C has to be used for computing the clustering C IFLAG - < 0 in case of error C IERROR - complementary information in case of error C e- =0 upon succesful return, > 0 otherwise C C LP, LPOK to control error printing C C C This routine traverses the tree in a DFS fashion using a pool C where nodes are pushed as soon as their parent is treated. Nodes C are pushed in the pool in the same order as FRERE_STEPS and, since C nodes are popped from the head of this pool, this means that C siblings are treated in reverse order. This makes it easier to C modify FRERE_STEPS because it will be always updated wrt a node C which has already been treated. The update of NA relies on the C assumption that a DFS touches the leaves in the same order as they C appear in NA (in reverse order in this case for what said above). C The roots are therefore pushed in the pool in reverse order. C An array of order NSTEPS is allocated to store the principal C variables of all the nodes that have been treated. This array C could be spared at the price of expensive pointer chasing inside C FILS. IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE, K489 INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: IRN(NZ8), JCN(NZ8), NE_STEPS(NSTEPS), & ICNTL(40) INTEGER, INTENT(INOUT) :: FILS(N), FRERE_STEPS(NSTEPS), STEP(N), & NA(LNA), DAD_STEPS(NSTEPS), LRGROUPS(N) 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 INTERFACE 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) INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) END SUBROUTINE END INTERFACE C Check for Schur (// or sequential) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF C If automatic choice of partitioning tool is required, then metis C comes first, if available; otherwise scotch; otherwise C permuted matrix is simply split. C If a particular tool C is required, we check for its availability, otherwise we revert to C automatic choice 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 C The global number of groups computed NBGROUPS = 0 C Build the unsymmetrized graph of the input matrix. The LGROUPS C array will be immediately allocated and used as a scratchpad C memory for ZMUMPS_ANA_GNEW IF (K265.EQ.-1) THEN C unsymmetric matrix, structurally symmetric LW = NZ8 ELSE C worst case need to double matrix size 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, IWFR, NRORM, NIORM, IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265) IF (allocated(IQ)) DEALLOCATE(IQ) C LRGROUPS has been used as a workspace in ana_gnew so we should C reinitialize it to -1 to be sure that a variable which is in no C group (ie in no grouped separator) can be identified correctly LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS C Push the roots in the pool in reverse order C DO I = 1, NROOTS C POOL(I) = NA(2+NLEAVES+NROOTS-I+1) C END DO C BUGFIX 18/11/2016 C Because the elements from the pool are taken in reverse order and the C NA is also updated in reverse order in MUMPS_UPD_TREE, this was C actually false! The roots should be pushed in the pool in natural C order. Cf email "Bugs L0" 18/11/2016. DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS C arrays of size N used to computed each halo 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 C Loop until the pool is empty DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) C This variable tells whether node is the oldest son of its parent. C In this case fils(fils(...fils(dad_steps(node)))) is updated FIRST = POOL(PP) .LT. 0 C Go down until the last variable in this front and make a list of C the fully assembled variables in it inside the work array NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO C Do the grouping. Upon return, work contains the variable in the C new order and NBGROUPS has been increased by the number of groups C computed in the current separator C Grouping is done if the current node is large enough, i.e. bigger C than the cluster size GROUP_SIZE. The grouping must be done C even if NV is smaller than SEP_SIZE: in that case, we give to all C of its variables a negative group number so that we have grouping C for all the variables which is needed in case we have for example C a chain like (say we do low-rank if nass > 8) father (nass=5) son (nass=10) C in this case we need a clustering of the CB of 'son' which may be partly C inherited from the clustering of the FS of 'father' so this latter C clustering should be done even if 'father' is not eligible for LR. Not C likely to happen often with metis-like ordering but it should be done C for robustness. C Moreover, as a front can be chosen for LR during facto even if the C separator was too small for proper grouping ( this occurs with delayed C pivots), we need the negative sign to avoid trying to do a LR facto in C such a case. 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 C Disable permutation/clustering. Leaves the ordering unchanged C and simply pack variables into groups of size SIZE_GROUP. C NB: this doesn't care about FS/CB, or about slaves, etc, so C it is useful only for a NIV1 root basically. DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+I/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + NV/GROUP_SIZE2 + 1 ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS(1), 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 C If NV is smaller than GROUP_SIZE then all variables are in a C single group, which value is negative if NV is also smaller C than SEP_SIZE. 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 C be careful, both val and -val are not present in the LRGROUPS array ENDIF C Update the tree according to the newly computed order CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS(1), FRERE_STEPS(1), STEP(1), DAD_STEPS(1), & NE_STEPS(1), NA(1), LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN C Restore potentially modified root number IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF C Put all the children of node in the pool. The first child is C always pushed with a negative index in order to establish when to C update the FILS array for the last variable in its parent (through C the FIRST variable above) 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) C RETURN END SUBROUTINE ZMUMPS_LR_GROUPING SUBROUTINE ZMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, K489, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, LPOK, LP) USE ZMUMPS_ANA_LR C This routine is meant to compute a grouping of the variables in C all the separators. This grouping defines the blocks that will C be compressed by means of low-rank approximations. Because the C principal variables of all separators will be changed, it is C necessary to update the arrays FILS, FRERE_STEPS, DAD_STEPS, STEP, C NA. C C N - the size of the input matrix C NZ8 - the nnz in the input matrix C NSTEPS - the numbers of nodes in the tree C IRN - the row indices of the input matrix C JCN - the col indices of the input matrix C FILS - the fils array of size N. This array will be C modified on output according to the new relative C order computed for the variables in the separators C FRERE_STEPS - the FRERE_STEPS array. Modified on output (as for FILS) C DAD_STEPS - the DAD_STEPS array. Modified on output (as for FILS) C NE_STEPS - the NE_STEPS array. Modified on output (as for FILS) C STEP - the STEP array. Modified on output (as for FILS) C NA - the NA array. Modified on output (as for FILS) C LNA - The length of the NA array C LRGROUPS - the array mapping variables onto groups. C LRGROUPS(i)=k means that variable i belongs to C group k C SYM - the type of matrix (KEEP(50)) C ICNTL - the ICNTL array C HALO_DEPTH - the depth of the halo around the separator subgraph C GROUP_SIZE - the size of variables groups in the separators C SEP_SIZE - the minimum size of a separator to be treated with C low-rank approximations C has to be used for computing the clustering C IFLAG - < 0 in case of error C IERROR - complementary information in case of error C e- =0 upon succesful return, > 0 otherwise C C LP, LPOK to control error printing C C C This routine traverses the tree in a DFS fashion using a pool C where nodes are pushed as soon as their parent is treated. Nodes C are pushed in the pool in the same order as FRERE_STEPS and, since C nodes are popped from the head of this pool, this means that C siblings are treated in reverse order. This makes it easier to C modify FRERE_STEPS because it will be always updated wrt a node C which has already been treated. The update of NA relies on the C assumption that a DFS touches the leaves in the same order as they C appear in NA (in reverse order in this case for what said above). C The roots are therefore pushed in the pool in reverse order. C An array of order NSTEPS is allocated to store the principal C variables of all the nodes that have been treated. This array C could be spared at the price of expensive pointer chasing inside C FILS. IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE, K489 INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: IRN(NZ8), JCN(NZ8), NE_STEPS(NSTEPS), & ICNTL(40) INTEGER, INTENT(INOUT) :: FILS(N), FRERE_STEPS(NSTEPS), STEP(N), & NA(LNA), DAD_STEPS(NSTEPS), LRGROUPS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, TARGET, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, POINTER, DIMENSION (:) :: TRACE_PTR, WORKH_PTR, & GEN2HALO_PTR INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR INTERFACE 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) INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) END SUBROUTINE END INTERFACE C Check for Schur (// or sequential) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF C If automatic choice of partitioning tool is required, then metis C comes first, if available; otherwise scotch; otherwise C permuted matrix is simply split. C If a particular tool C is required, we check for its availability, otherwise we revert to C automatic choice 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 C The global number of groups computed NBGROUPS = 0 C Build the unsymmetrized graph of the input matrix. The LGROUPS C array will be immediately allocated and used as a scratchpad C memory for ZMUMPS_ANA_GNEW 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, IWFR, NRORM, NIORM, IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265) IF (allocated(IQ)) DEALLOCATE(IQ) C LRGROUPS has been used as a workspace in ana_gnew so we should C reinitialize it to -1 to be sure that a variable which is in no C group (ie in no grouped separator) can be identified correctly LRGROUPS = -1 IF (K469.NE.2) THEN C K469=1 or 3: arrays of size N shared by all threads 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 !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, !$OMP& WORKH_PTR, TRACE_PTR, GEN2HALO_PTR) IF(K469.GT.1) ALLOCATE(WORK(MAXFRONT), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT IFLAG = -7 IERROR = MAXFRONT GOTO 500 ENDIF IF (K469.EQ.2) THEN C K469=2: arrays of size N allocated on each thread ALLOCATE(TRACE_PTR(N), WORKH_PTR(N), GEN2HALO_PTR(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 500 ENDIF ELSE TRACE_PTR => TRACE WORKH_PTR => WORKH GEN2HALO_PTR => GEN2HALO ENDIF IF (K469.EQ.2) THEN TRACE_PTR = 0 ELSE !$OMP SINGLE TRACE_PTR = 0 !$OMP END SINGLE ENDIF C I) Parcours parallele en N pour initialiser PVS PVSCHANGED = .FALSE. !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO C II) Parcours parallele en NSTEPS pour faire le grouping avec C PVS, STEP et FILS (sauf derniere variable) qui sont mis a jour !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) C Construire VLIST a partir de FILS(PV) C Go down until the last variable in this front and make a list of C the fully assembled variables in it inside the work array NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO C Appel a SEP_GROUPING sur VLIST: la variable principale de NODE C change et devient PVS(NODE) C Do the grouping. Upon return, work contains the variable in the C new order and NBGROUPS has been increased by the number of groups C computed in the current separator C Grouping is done if the current node is large enough, i.e. bigger C than the cluster size GROUP_SIZE. The grouping must be done C even if NV is smaller than SEP_SIZE: in that case, we give to all C of its variables a negative group number so that we have grouping C for all the variables which is needed in case we have for example C a chain like (say we do low-rank if nass > 8) father (nass=5) son (nass=10) C in this case we need a clustering of the CB of 'son' which may be partly C inherited from the clustering of the FS of 'father' so this latter C clustering should be done even if 'father' is not eligible for LR. Not C likely to happen often with metis-like ordering but it should be done C for robustness. C Moreover, as a front can be chosen for LR during facto even if the C separator was too small for proper grouping ( this occurs with delayed C pivots), we need the negative sign to avoid trying to do a LR facto in C such a case. 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 C C Disable permutation/clustering. Leaves the ordering unchanged C and simply pack variables into groups of size SIZE_GROUP. C NB: this doesn't care about FS/CB, or about slaves, etc, so C it is useful only for a NIV1 root basically. !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+I/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + NV/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS(1), NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PTR, WORKH_PTR, & NODE, GEN2HALO_PTR, K482_LOC, K472, K469, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) CYCLE C Maj de PVS PVS(NODE) = WORK(1) PVSCHANGED = .TRUE. C Maj de STEP 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 C Maj de FILS DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN C La derniere variable de FILS memorise l'ancienne C variable principale pointee FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE C If NV is smaller than GROUP_SIZE then all variables are in a C single group, which value is negative if NV is also smaller C than SEP_SIZE. !$OMP CRITICAL(lrgrouping_cri) 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 !$OMP END CRITICAL(lrgrouping_cri) ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 C <<<< Synchro >>>> C A ce stade tous les noeuds ont ete traites et PVS, STEP et FILS (sauf derniere variable) C sont a jour C On economise les maj suivantes si inutiles IF (.NOT.PVSCHANGED) GOTO 500 C III) Maj de DAD_STEPS, FRERE_STEPS, NA, et derniere variable de chaque noeud de FILS !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN C Node has a younger brother, update frere_steps(node) FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN C node is the youngest brother, update frere_steps(node) to make C it point to the father 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.EQ.2) THEN DEALLOCATE(TRACE_PTR) DEALLOCATE(WORKH_PTR) DEALLOCATE(GEN2HALO_PTR) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469.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) C RETURN END SUBROUTINE ZMUMPS_LR_GROUPING_NEW C SUBROUTINE SEP_GROUPING(NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, C & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH) C IMPLICIT NONE C INTEGER :: NV, N, NZ, LW, NBGROUPS, GROUP_SIZE, HALO_DEPTH C INTEGER :: VLIST(NV), LRGROUPS(N), IW(LW), IPE(N+1), LEN(N) C C INTEGER :: TMP, I C CC Just invert the list C DO I=1, NV/2 C TMP = VLIST(I) C VLIST(I) = VLIST(NV-I+1) C VLIST(NV-I+1) = TMP C END DO C C RETURN C END SUBROUTINE SEP_GROUPING MUMPS_5.1.2/src/dfac_asm_ELT.F0000664000175000017500000001746113164366263016106 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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(8) :: POSELT 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)) POSELT = PTRAST(STEP(INODE)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS) END IF 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 END DO END IF 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) 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) 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 :: 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)) A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = ZERO NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) 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.1.2/src/sfac_distrib_ELT.F0000664000175000017500000004703213164366262017001 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 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)) ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF 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 ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC)=ZERO ENDDO ENDIF 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 ARROW_ROOT = ARROW_ROOT + 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)==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) 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 ) ARROW_ROOT = ARROW_ROOT + NB_REC 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 (KEEP(38).ne.0) THEN DEALLOCATE(ELROOTPOS8) 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.1.2/src/smumps_save_restore.F0000664000175000017500000000071713164366263017746 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_SAVE_RESTORE_RETURN() RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_RETURN MUMPS_5.1.2/src/cooc_panel_piv.F0000664000175000017500000002756513164366266016636 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zfac_scalings_simScaleAbs.F0000664000175000017500000014000213164366266020710 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 Check done outside C IF(ISTATUS + NUMPROCS * MPI_STATUS_SIZE - 1>INTSZ) THEN C write(6,*) "Bora: ", ISTATUS + C & NUMPROCS * MPI_STATUS_SIZE - 1,INTSZ C write(6,*) "Bora : TODO. scimscaent_33 REPORT ERROR" C CALL flush(6) C ENDIF 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 C Check done outside C IF( OSRCPTR + OCSNDRCVVOL - 1 > RESZ) THEN C write(6,*) "Bora: NOTE: ", C & OSRCPTR + OCSNDRCVVOL - 1 , RESZ C write(6,*) "Bora: TODO. scimscaent_3 REPORT ERROR" C CALL flush(6) C 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),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 C write(6,*) 'Bora :', RESZ, N, IRSNDRCVVOL, ORSNDRCVVOL C CALL flush(6) 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(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.1.2/src/dfac_process_bf.F0000664000175000017500000000071313164366263016737 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE DMUMPS_PROCESS_BF_RETURN MUMPS_5.1.2/src/cfac_process_blocfacto.F0000664000175000017500000006567113164366264020322 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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 USE CMUMPS_LOAD USE CMUMPS_LR_STATS USE CMUMPS_LR_CORE USE CMUMPS_LR_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_DECOMPRESS_PANEL, & CMUMPS_COMPRESS_PANEL, & CMUMPS_BLR_UPDATE_TRAILING, & CMUMPS_FAKE_COMPRESS_CB USE CMUMPS_ANA_LR, ONLY : GET_CUT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ), 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), 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) :: LAELL INTEGER(8) :: POSELT INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, LPOS1, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTBL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX ONE,ALPHA PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO INTEGER :: SEND_LR_INT, NELIM, NPARTSASS_MASTER, & CURRENT_BLR_PANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: SEND_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U 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 INTEGER T1, T2, COUNT_RATE COMPLEX, DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL :: DYNAMIC_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE 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, CURRENT_BLR_PANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF IF ( SEND_LR ) THEN LAELL = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LAELL = int(NPIV,8) * int(NCOL,8) ENDIF IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLUS, IERROR) IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN LP=ICNTL(1) WRITE(LP,*) &" FAILURE, WORKSPACE TOO SMALL DURING CMUMPS_PROCESS_BLOCFACTO" ENDIF GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress CMUMPS_PROCESS_BLOCFACTO, LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR( LAELL-LRLUS, IERROR ) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN LP=ICNTL(1) WRITE(LP,*) &" FAILURE IN INTEGER ALLOCATION DURING CMUMPS_PROCESS_BLOCFACTO" ENDIF IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LAELL,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 ( SEND_LR ) 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))) ALLOCATE(BEGS_BLR_U(NB_BLR_U+2)) CALL CMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, KEEP(470), & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTRIST(STEP(INODE))+XXNBPR)) DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) #else DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) POSELT = PTRAST(STEP(INODE)) LCONT1 = IW( IOLDPS +KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 +KEEP(IXSZ)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) ELSE CALL CMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS) 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(IPOS), NCOL1, A(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(IPOS), NCOL1, A(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF (KEEP(486) .GT.0) THEN CALL SYSTEM_CLOCK(T1) ENDIF IF (DYNAMIC_ALLOC) THEN CALL ctrsm('L','L','N','N',NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, A(LPOS2), NCOL1) ELSE CALL ctrsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, A(LPOS2), NCOL1) ENDIF IF (KEEP(486) .GT.0) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_TRSM_TIME = ACC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (SEND_LR) THEN 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 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) MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) 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)) CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL & (A, LA, POSELT, IFLAG, IERROR, NCOL1, & BEGS_BLR_L, NB_BLR_L+1, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #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. & ( .NOT. SEND_LR .OR. (NPIV .EQ.0) .OR. & (KEEP(485).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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (SEND_LR) THEN IF (NELIM.GT.0) THEN IF (DYNAMIC_ALLOC) THEN LPOS1 = int(NPIV+1,8) CALL cgemm('N','N', NELIM,NROW1,NPIV, & ALPHA,DYN_BLOCFACTO(LPOS1),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ELSE LPOS1 = POSBLOCFACTO+int(NPIV,8) CALL cgemm('N','N', NELIM,NROW1,NPIV, & ALPHA,A(LPOS1),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, & BLR_L, NB_BLR_L+1, & BLR_U, NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, KEEP(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_UPDT_TIME = ACC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & 0, NPARTSCB, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, & .FALSE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L, CURRENT_BLR, 'V', NCOL1, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (KEEP(201).eq.1) 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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF ENDIF ELSE IF (DYNAMIC_ALLOC) THEN LPOS1 = int(NPIV+1,8) CALL cgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,DYN_BLOCFACTO(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ELSE LPOS1 = POSBLOCFACTO+int(NPIV,8) CALL cgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,A(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(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 (SEND_LR) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, .FALSE.) DEALLOCATE(BLR_U) CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8, .TRUE.) DEALLOCATE(BLR_L) ENDIF ENDIF IF (DYNAMIC_ALLOC) THEN DEALLOCATE(DYN_BLOCFACTO) DEALLOCATE(DYN_PIVINFO) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,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 (SEND_LR) 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 (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN CALL CMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_L, NB_BLR_L+1, & BEGS_BLR_U, NB_BLR_U+1, 1, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., NPIV1, KEEP(484)) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 (SEND_LR) 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 ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_L)) DEALLOCATE(BEGS_BLR_L) 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, K470, & 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, K470 CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(OUT) :: IERR, IFLAG, IERROR 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 :: LRFORM, K, M, N, KSVD 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, & LRFORM, 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & KSVD, 1, & MPI_INTEGER, COMM, IERR ) IF (DIR.EQ.'H') THEN IF (K470.EQ.1) THEN BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M ELSE BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + N ENDIF ELSE BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M ENDIF IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, KSVD, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (LRFORM .NE. BLR_U(I)%LRFORM) THEN WRITE(*,*) "Internal error 2 in ALLOC_LRB", & LRFORM, BLR_U(I)%LRFORM ENDIF 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.1.2/src/sfac_scalings.F0000664000175000017500000002670713164366262016446 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), INFO(40) 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(OUT) :: 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.1.2/src/mumps_scotch64.h0000664000175000017500000000255113164366240016552 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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) /* esmumps prototype with 64-bit integers */ 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 ); #endif #endif MUMPS_5.1.2/src/zfac_process_end_facto_slave.F0000664000175000017500000002373013164366265021520 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ) 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 #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) CALL ZMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF), IFLAG, KEEP8, .TRUE.) IW(IOLDPS+XXS)=S_ALL 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, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG 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(70) = KEEP8(70) + MEM_GAIN KEEP8(71) = KEEP8(71) + MEM_GAIN CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) 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 IW(IOLDPS+XXS)=S_NOLCBCONTIG 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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, 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(70) = KEEP8(70) + MEM_GAIN KEEP8(71) = KEEP8(71) + 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/zfac_process_root2son.F0000664000175000017500000003232013164366265020164 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 40 ) 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 NBPROCFILS(KEEP(28)) 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 ) 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)),SLAVEF) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & SLAVEF ).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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), SLAVEF) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 7 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO #endif ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 9 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO_SYM #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, 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.1.2/src/ssol_aux.F0000664000175000017500000010321513164366262015472 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) REAL W(N), X(N) REAL, intent(inout) :: EST 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) 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) 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 ) 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 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) 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) 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) 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)) 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)) 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) # if defined(RHSCOMP_BYROWS) REAL, INTENT(INOUT) :: RHSCOMP(NRHS,LRHSCOMP) # else REAL, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) # endif INTEGER :: LD_W, FIRST_ROW_W REAL :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT #if defined(RHSCOMP_BYROWS) !$OMP PARALLEL DO PRIVATE (ISHIFT, K), IF !$OMP& ((NBROWS) * (JBFIN-JBDEB+1) > KEEP(363)) DO JJ = 0, NBROWS-1 ISHIFT = FIRST_ROW_W+JJ DO K = JBDEB, JBFIN RHSCOMP(K,FIRST_ROW_RHSCOMP+JJ) = & W(ISHIFT+LD_W*(K-JBDEB)) END DO END DO !$OMP END PARALLEL DO #else !$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 #endif 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) # if defined(RHSCOMP_BYROWS) REAL, INTENT(INOUT) :: RHSCOMP(NRHS,LRHSCOMP) # else REAL, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) # endif REAL :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSCOMP_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSCOMP #if defined(RHSCOMP_BYROWS) !$OMP PARALLEL DO PRIVATE(K,ISHIFT,IPOSINRHSCOMP), IF !$OMP& ((JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>KEEP(363)) DO JJ = J1, J2-KEEP(253) ISHIFT = FIRST_ROW_W+JJ-J1 IPOSINRHSCOMP = abs(POSINRHSCOMP_BWD(IW(JJ))) DO K=JBDEB, JBFIN W(ISHIFT+(K-JBDEB)*LD_W) = RHSCOMP(K,IPOSINRHSCOMP) ENDDO ENDDO !$OMP END PARALLEL DO #else !$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 #endif 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(40), 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 MUMPS_5.1.2/src/zfac_par_m.F0000664000175000017500000007735313164366266015757 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS,ND,FILS,STEP, & FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, NTOTPV, NMAXNPIV, PTRIST, PTRAST, & PIMASTER, PAMASTER, PTRARW, PTRAIW, & ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, & LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, NSTEPS, 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_LR 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER N,NTOTPV,MAXFRT,LIW, LPTRAR, NMAXNPIV, & NSTEPS, INFO(40) 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(40) 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)), NBPROCFILS(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 MAXFRW, NPVW, NOFFW, NELVAW, COMP, & JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' DOUBLE PRECISION OPASSW, OPELIW ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL PTRIST(1:KEEP(28))=0 PTLUST(1:KEEP(28))=0 PTRAST(1:KEEP(28))=0_8 PTRFAC(1:KEEP(28))=-99999_8 PIMASTER(1:KEEP(28))=-99999_8 PAMASTER(1:KEEP(28))=-99999_8 MP = ICNTL(2) LP = ICNTL(1) MAXFRW = 0 NPVW = 0 NOFFW = 0 NELVAW = 0 COMP = 0 OPASSW = DZERO OPELIW = DZERO IWPOSCB = LIW 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, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 NBPROCFILS(1:KEEP(28)) = 0 #if ! defined(NO_XXNBPR) KEEP(121)=0 #endif IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL ZMUMPS_ROOT_ALLOC_STATIC( & root, KEEP(38), N, IW, LIW, & A, LA, & FILS, MYID_NODES, 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 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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 (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)),SLAVEF) 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, NOFFW, NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ELSE CALL ZMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, NOFFW, NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ( 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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,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, & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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,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, & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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 ( INFO(1) .LT. 0 ) GOTO 640 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTLUST(STEP(INODE))+XXNBPR) ) IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN #else IF ((NBPROCFILS(STEP(INODE)).GT.0).OR.(SON_LEVEL2)) THEN #endif 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, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NBPROCFILS, 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, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF 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, NOFFW, NPVW, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & ) ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL ZMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFW, NPVW, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & ) 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,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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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 (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) 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),OPELIW,NELVAW,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, & LRLUS,IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, NBPROCFILS, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, OPASSW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) 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)),SLAVEF).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)),SLAVEF)) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, 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,SLAVEF, & 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) .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)))), & SLAVEF) 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( 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, & OPELIW ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & SLAVEF) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NPVW = NPVW + INFO(2) ELSE NPVW = NPVW + 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(70) = KEEP8(70) + ITMP8 KEEP8(71) = KEEP8(71) + 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 CALL MUMPS_SET_IERROR(LRHS_CNTR_MASTER_ROOT,INFO(2)) 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)) NPVW = NPVW + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & NFRONT8*NFRONT8 ) THEN POSFAC = POSFAC - NFRONT8*NFRONT8 LRLUS = LRLUS + NFRONT8*NFRONT8 LRLU = LRLUS + NFRONT8*NFRONT8 KEEP8(70) = KEEP8(70) + NFRONT8*NFRONT8 KEEP8(71) = KEEP8(71) + NFRONT8*NFRONT8 CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-NFRONT8*NFRONT8,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))),SLAVEF) & ) THEN MAXFRW = max ( MAXFRW, root%TOT_ROOT_SIZE) END IF END IF MAXFRT = MAXFRW NTOTPV = NPVW INFO(12) = NOFFW RINFO(2) = dble(OPASSW) RINFO(3) = dble(OPELIW) INFO(13) = NELVAW INFO(14) = COMP 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.1.2/src/zfac_sol_pool.F0000664000175000017500000004543313164366265016500 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & K28, K76, K80, K47, STEP, INODE) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47 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)), & SLAVEF)) & ) 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)), & SLAVEF) ) 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 defined(NOT_ATM_POOL_SPECIAL) J=NBTOP #else 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 #endif DO I=J,1,-1 #if defined(NOT_ATM_POOL_SPECIAL) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE = POOL(LPOOL-2-I) - N ELSE NODE = POOL(LPOOL-2-I) ENDIF #else NODE=POOL(LPOOL-2-I) #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 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ELSEIF(KEEP(81).EQ.3)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) 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)), SLAVEF) ) 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)), & SLAVEF)) 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)), & SLAVEF) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & SLAVEF)) 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GT.0).AND.(INODE.LE.N))THEN #endif 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) #if ! defined(NOT_ATM_POOL_SPECIAL) ELSE ENDIF #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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GT.0).AND.(INODE.LT.N))THEN #endif SBTR_FLAG=(NBINSUBTREE.NE.0) #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #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)), & SLAVEF))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.1.2/src/dfac_sol_pool.F0000664000175000017500000004543313164366263016450 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & K28, K76, K80, K47, STEP, INODE) USE DMUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47 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)), & SLAVEF)) & ) 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)), & SLAVEF) ) 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 defined(NOT_ATM_POOL_SPECIAL) J=NBTOP #else 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 #endif DO I=J,1,-1 #if defined(NOT_ATM_POOL_SPECIAL) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE = POOL(LPOOL-2-I) - N ELSE NODE = POOL(LPOOL-2-I) ENDIF #else NODE=POOL(LPOOL-2-I) #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 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ELSEIF(KEEP(81).EQ.3)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) 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)), SLAVEF) ) 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)), & SLAVEF)) 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)), & SLAVEF) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & SLAVEF)) 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GT.0).AND.(INODE.LE.N))THEN #endif 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) #if ! defined(NOT_ATM_POOL_SPECIAL) ELSE ENDIF #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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GT.0).AND.(INODE.LT.N))THEN #endif SBTR_FLAG=(NBINSUBTREE.NE.0) #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #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)), & SLAVEF))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.1.2/src/send_driver.F0000664000175000017500000003156413164366266016154 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) 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%PROCNODE)) THEN DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) 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 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 -------------- C Receive buffer C -------------- IF ( associated( id%BUFR ) ) DEALLOCATE( id%BUFR ) NULLIFY( id%BUFR ) 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_AFTER_L0_OMP)) THEN DEALLOCATE(id%IPOOL_AFTER_L0_OMP) NULLIFY(id%IPOOL_AFTER_L0_OMP) END IF IF (associated(id%IPOOL_BEFORE_L0_OMP)) THEN DEALLOCATE(id%IPOOL_BEFORE_L0_OMP) NULLIFY(id%IPOOL_BEFORE_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%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 RETURN END SUBROUTINE SMUMPS_END_DRIVER MUMPS_5.1.2/src/dfac_process_band.F0000664000175000017500000002365313164366263017264 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & TNBPROCFILS, N, IW, LIW, A, LA, & 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 #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(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & TNBPROCFILS( 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 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 ) IBUFR = 10 #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, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, 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+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 TNBPROCFILS(STEP( INODE )) = NBPROCFILS # if ! defined(NO_XXNBPR) IW(IWPOSCB+1+XXNBPR)=NBPROCFILS # endif IW(IWPOSCB+1+XXLR)=LRSTATUS 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' INTEGER, INTENT(IN) :: INODE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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)), & SLAVEF ) # 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, & NBPROCFILS, N, IW, LIW, A, LA, & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/dfac_mem_free_block_cb.F0000664000175000017500000000553513164366263020216 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_FREE_BLOCK_CB(SSARBR, MYID, N, IPOSBLOCK, & RPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) USE DMUMPS_LOAD IMPLICIT NONE INTEGER(8) :: RPOSBLOCK 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 INCLUDE 'mumps_headers.h' IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ) SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) ) 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 ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF ENDIF 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 IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF ENDIF 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 MUMPS_5.1.2/src/sfac_lr.F0000664000175000017500000010573313164366263015256 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE SMUMPS_FAC_LR USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_ANA_LR 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, & COMPRESS_MID_PRODUCT, TOLEPS, 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 INTEGER, intent(out) :: IFLAG, IERROR REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR-CURRENT_BLR) REAL, INTENT(INOUT), TARGET :: BLOCK(:,:) INTEGER, intent(in) :: IW2(*) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK REAL, POINTER, DIMENSION(:) :: BLOCK_PTR 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 BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,1) #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, BLOCK_PTR, !$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 = OMP_GET_THREAD_NUM() BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1) #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL SMUMPS_LRGEMM3('N', 'T', MONE, & BLR_L(J),BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, NFRONT, & IW2, & BLOCK_PTR, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_L(J), BLR_L(I), 'N', & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ & , (I.EQ.J) & ) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE SMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, POSBLOCFACTO, 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, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, POSBLOCFACTO REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(out) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), & 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, POINTER, 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) :: COMPRESS_MID_PRODUCT, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ 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 = POSBLOCFACTO #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, 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 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_LRGEMM3('N', 'T', MONE, & BLR_LM(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, 2, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, LD_BLOCFACTO, & IW2, & BLOCK, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LM(J), BLR_LS(I), & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, & .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, 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 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_LRGEMM3('N', 'T', MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, 2, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, LD_BLOCFACTO, & IW2, & BLOCK, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LS(J), BLR_LS(I), & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, & (I.EQ.J)) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE SMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT SUBROUTINE SMUMPS_BLR_UPDATE_NELIM_VAR( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, CURRENT_BLR, & NELIM, SYM, NIV, FIRST_BLOCK LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(out) :: IFLAG, IERROR INTEGER, intent(in) :: ISHIFT REAL, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL, IS INTEGER :: allocok 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 IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if defined(BLR_MT) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = FIRST_BLOCK-CURRENT_BLR, 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 write(*,*) 'Allocation problem in BLR routine & SMUMPS_BLR_UPDATE_NELIM_VAR: ', & 'not enough memory? memory requested = ', IERROR 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 IF (SYM.EQ.0) THEN 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) ELSE POSELT_TOP = POSELT + int(NFRONT,8) & * int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) & + int((BEGS_BLR_L(CURRENT_BLR)-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('T' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDIF ENDDO ENDIF 100 CONTINUE #if defined(BLR_MT) !$OMP END SINGLE #endif END SUBROUTINE SMUMPS_BLR_UPDATE_NELIM_VAR 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, K470, & COMPRESS_MID_PRODUCT, TOLEPS, 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, K470, & NELIM, NIV, SYM INTEGER, intent(out) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT REAL, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, 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 CHARACTER(len=1) :: TRANSB1 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 write(*,*) 'Allocation problem in BLR routine & SMUMPS_BLR_UPDATE_TRAILING: ', & 'not enough memory? memory requested = ', IERROR 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) IF (SYM.EQ.0) THEN IF (K470.EQ.1) THEN TRANSB1 = 'N' ELSE TRANSB1 = 'T' ENDIF CALL SMUMPS_LRGEMM3(TRANSB1, 'T', MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, & KPERCENT, MID_RANK, BUILDQ) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), & TRANSB1, & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) ELSE CALL SMUMPS_LRGEMM3('N', 'T', MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, & KPERCENT, MID_RANK, BUILDQ) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), 'N', & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING SUBROUTINE SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & LD_OR_NPIV, K470, & BEG_I_IN, END_I_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) :: NFRONT, 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) :: LD_OR_NPIV, K470 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN INTEGER :: IP, M, N, BIP, BEG_I, END_I #if defined(BLR_MT) INTEGER :: LAST_IP, CHUNK #endif INTEGER :: K, I INTEGER(8) :: POSELT_BLOCK, NFRONT8, 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 NFRONT8 = int(NFRONT,8) LD_BLK_IN_FRONT = NFRONT8 BIP = BEGS_BLR_FIRST_OFFDIAG #if defined(BLR_MT) LAST_IP = BEG_I CHUNK = 1 !$OMP PARALLEL DO PRIVATE(POSELT_BLOCK, M, N, K, I) !$OMP& FIRSTPRIVATE(BIP, LAST_IP) SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if defined(BLR_MT) DO I = 1, IP - LAST_IP IF (DIR .eq. 'V') THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ELSE IF (K470.EQ.1) THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ELSE BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N ENDIF ENDIF ENDDO LAST_IP = IP #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LD_OR_NPIV) THEN POSELT_BLOCK = POSELT + NFRONT8*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ELSE POSELT_BLOCK = POSELT +NFRONT8*int(LD_OR_NPIV,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LD_OR_NPIV,8)*int(BIP-1-LD_OR_NPIV,8) LD_BLK_IN_FRONT=int(LD_OR_NPIV,8) ENDIF ELSE POSELT_BLOCK = POSELT + & NFRONT8*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 K = BLR_PANEL(IP-CURRENT_BLR)%K IF ((BLR_PANEL(IP-CURRENT_BLR)%ISLR).AND. & (BLR_PANEL(IP-CURRENT_BLR)%LRFORM.EQ.1)) THEN IF (K.EQ.0) THEN IF (K470.NE.1.OR.DIR .eq. 'V') THEN DO I = 1, M 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 = 1, N A(POSELT_BLOCK+int(I-1,8)*NFRONT8: & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (K470.NE.1.OR.DIR .eq. 'V') THEN 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)) ELSE CALL sgemm('N', 'N', M, N, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & ZERO, A(POSELT_BLOCK), NFRONT) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (K470.NE.1.OR.DIR .eq. 'V') THEN DO I = 1, M 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 = 1, N A(POSELT_BLOCK+int(I-1,8)*NFRONT8: & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if !defined(BLR_MT) IF (DIR .eq. 'V') THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ELSE IF (K470.EQ.1) THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ELSE BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%N ENDIF ENDIF #endif END DO #if defined(BLR_MT) !$OMP END PARALLEL DO #endif END SUBROUTINE SMUMPS_DECOMPRESS_PANEL SUBROUTINE SMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR_L, NB_BLR_L, & BEGS_BLR_U, NB_BLR_U, NPARTSASS_U, & TOLEPS, NASS, NROW, & SYM, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, INODE, NIV, & LBANDSLAVE, ISHIFT,KPERCENT) INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, INODE INTEGER, INTENT(IN) :: NIV, NROW, KPERCENT INTEGER :: MAXI_CLUSTER, LWORK, SYM, NASS, & NB_BLR_L, NB_BLR_U, NPARTSASS_U REAL,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U REAL :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER) REAL,DIMENSION(:) :: RWORK REAL, DIMENSION(:) :: WORK, TAU INTEGER, DIMENSION(:) :: JPVT INTEGER :: M, N, NCB, BEGLOOP, RANK, MAXRANK, FRONT_CB_BLR_SAVINGS INTEGER :: INFO, I, J, JJ, IB, JDEB, IS INTEGER :: allocok, MREQ INTEGER(8) :: POSELT_BLOCK DOUBLE PRECISION :: HR_COST, BUILDQ_COST, CB_DEMOTE_COST, & CB_PROMOTE_COST INTEGER T1, T2, COUNT_RATE DOUBLE PRECISION :: LOC_PROMOTING_TIME DOUBLE PRECISION :: LOC_CB_DEMOTING_TIME REAL, ALLOCATABLE :: R(:,:) REAL :: ONE, ZERO PARAMETER (ONE = 1.0E0) PARAMETER (ZERO = 0.0D0) LOC_PROMOTING_TIME = 0.0D0 LOC_CB_DEMOTING_TIME = 0.0D0 CB_DEMOTE_COST = 0.0D0 CB_PROMOTE_COST = 0.0D0 allocate(R(MAXI_CLUSTER,MAXI_CLUSTER),stat=allocok) IF (allocok .GT. 0) THEN MREQ=MAXI_CLUSTER*MAXI_CLUSTER write(*,*) 'Allocation problem in BLR routine & SMUMPS_FAKE_COMPRESS_CB: ', & 'not enough memory? memory requested = ', MREQ CALL MUMPS_ABORT() ENDIF FRONT_CB_BLR_SAVINGS = 0 NCB = NFRONT - NASS IF (NCB.LE.0) RETURN IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF DO J = NPARTSASS_U+1, NB_BLR_U IF (NIV.EQ.1) THEN IF (SYM.GT.0) THEN BEGLOOP = J ELSE BEGLOOP = NPARTSASS_U + 1 ENDIF ELSE BEGLOOP = 2 ENDIF IF ((BEGS_BLR_U(J+1)+IS).LE.NASS+1) CYCLE JDEB = max(BEGS_BLR_U(J)+IS,NASS+1) N = BEGS_BLR_U(J+1)+IS-JDEB DO I = BEGLOOP, NB_BLR_L CALL SYSTEM_CLOCK(T1) JPVT = 0 M = BEGS_BLR_L(I+1)-BEGS_BLR_L(I) POSELT_BLOCK = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(I)-1),8) & + int(JDEB - 1,8) DO IB=1,M IF((I.EQ.J).AND.(SYM.GT.0).AND.(NIV.EQ.1)) THEN BLOCK(IB,1:IB) = & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : & POSELT_BLOCK+ & int((IB-1),8)*int(NFRONT,8)+int(IB-1,8) ) BLOCK(1:IB-1,IB) = BLOCK(IB,1:IB-1) ELSE BLOCK(IB,1:N) = & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8)+int(N-1,8) ) ENDIF END DO MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL SMUMPS_TRUNCATED_RRQR( M, N, BLOCK(1,1), & MAXI_CLUSTER, JPVT(1), TAU(1), WORK(1), N, & RWORK(1), TOLEPS, RANK, MAXRANK, INFO ) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_CB_DEMOTING_TIME = LOC_CB_DEMOTING_TIME & + DBLE(T2-T1)/DBLE(COUNT_RATE) IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK & IN CB (FAKE COMPRESSION anyway) " CALL MUMPS_ABORT() END IF HR_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(RANK)/3.0D0 & + 4.0D0*dble(RANK)*dble(M)*dble(N) & - 2.0D0*dble((M+N))*dble(RANK)*dble(RANK) IF (RANK.LE.MAXRANK) THEN CALL SYSTEM_CLOCK(T1) DO JJ=1, N R(1:MIN(RANK,JJ),JPVT(JJ)) = & BLOCK(1:MIN(RANK,JJ),JJ) IF(JJ.LT.RANK) R(MIN(RANK,JJ)+1: & RANK,JPVT(JJ))= ZERO END DO CALL sorgqr(M, RANK, RANK, & BLOCK(1,1), MAXI_CLUSTER, & TAU(1), WORK(1), LWORK, INFO) CALL sgemm('T', 'T', N, M, RANK, ONE , & R , MAXI_CLUSTER, & BLOCK(1,1) , MAXI_CLUSTER, & ZERO, A(POSELT_BLOCK), NFRONT) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) BUILDQ_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(M) & - dble(RANK)*dble(RANK)*dble(RANK) & CB_DEMOTE_COST = CB_DEMOTE_COST + & (HR_COST+BUILDQ_COST) CB_PROMOTE_COST = CB_PROMOTE_COST + & 2.0D0*dble(RANK)*dble(M)*dble(N) FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & (M-RANK)*(N-RANK)-RANK*RANK ELSE CB_DEMOTE_COST = CB_DEMOTE_COST + HR_COST END IF END DO END DO deallocate(R) CALL STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS) CALL UPDATE_FLOP_STATS_CB_DEMOTE(CB_DEMOTE_COST, NIV) CALL UPDATE_FLOP_STATS_CB_PROMOTE(CB_PROMOTE_COST, NIV) CALL UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME) CALL UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME) END SUBROUTINE SMUMPS_FAKE_COMPRESS_CB SUBROUTINE SMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, K473, BLR_PANEL, CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & K470, KEEP8, K480, & 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, CURRENT_BLR, NIV INTEGER, intent(out) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) REAL, intent(inout) :: A(LA) REAL, TARGET, DIMENSION(:) :: RWORK REAL, TARGET, DIMENSION(:,:) :: BLOCK REAL, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER, POINTER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, K470 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 IF (K470.EQ.1) THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE M = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF 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 = 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 (DIR .eq. 'V') THEN M = BEGS_BLR(IP+1)-BEGS_BLR(IP) POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE IF (K470.EQ.1) THEN M = BEGS_BLR(IP+1)-BEGS_BLR(IP) ELSE N = BEGS_BLR(IP+1)-BEGS_BLR(IP) ENDIF POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) END IF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF IF (K470.NE.1.OR.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, 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, RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE BLR_PANEL(IP-CURRENT_BLR)%Q = ZERO DO I=1,RANK BLR_PANEL(IP-CURRENT_BLR)%Q(I,I) = ONE END DO CALL sormqr & ('L', 'N', M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), & M, WORK_THR(1), LWORK, INFO ) IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNMQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF 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 UPDATE_FLOP_STATS_DEMOTE( & BLR_PANEL(IP-CURRENT_BLR), NIV) END IF ELSE IF (K470.NE.1.OR.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 CALL UPDATE_FLOP_STATS_DEMOTE(BLR_PANEL(IP-CURRENT_BLR), & NIV) ENDIF BLR_PANEL(IP-CURRENT_BLR)%K = -1 END IF END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE SMUMPS_COMPRESS_PANEL END MODULE SMUMPS_FAC_LR MUMPS_5.1.2/src/zfac_process_blfac_slave.F0000664000175000017500000004075313164366265020651 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS(KEEP(28)), 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 ) 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 IOLDPS, LCONT1, NROW1, NCOL1, NPIV1, NASS1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok LOGICAL SEND_LR INTEGER SEND_LR_INT 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 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, NB_BLR_COL, NPARTSASS_MASTER INTEGER :: MAXI_CLUSTER_TMP, MAXI_CLUSTER COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:):: BLOCKLR INTEGER :: LWORK DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK 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, & SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF IF (SEND_LR) 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))) ALLOCATE(BEGS_BLR_U(NB_BLR_U+2)) CALL ZMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, KEEP(470), & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) IF ( LRLU .LT. LAELL ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLUS, IERROR) GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ZMUMPS_PROCESS_BLFAC_SLAVE' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLU, IERROR) GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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 (SEND_LR) THEN DYNAMIC = .FALSE. ENDIF IF (DYNAMIC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN write(*,*) MYID, ' : PB allocation U in blfac_slave ' & , LAELL 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(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) ) #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(INODE)) + 9 + KEEP(IXSZ) ) #else MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 )) POSELT = PTRAST(STEP( INODE )) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NASS1 = IW( IOLDPS + 1 + 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 (SEND_LR) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_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 ( & A, LA, POSELT, IFLAG, IERROR, NCOL1, & BEGS_BLR_LS, BEGS_BLR_U, & CURRENT_BLR_U, & BLR_LS, NB_BLR_LS+1, & BLR_U, NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, KEEP(470), & KEEP(481), DKEEP(8), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR_U, KEEP8, .FALSE.) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) CALL ZMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8, .TRUE.) 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( LPOS ), NCOL1, ONE, & A( CPOS ), NCOL1 ) ELSE CALL zgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A( LPOS ), NCOL1, ONE, & A( 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.SEND_LR) THEN IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + 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)), SLAVEF ) 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 IF (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN IOLDPS = PTRIST(STEP( INODE )) CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) NB_BLR_LS = size(BEGS_BLR_LS) - 2 CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 CALL MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_TMP) MAXI_CLUSTER = MAXI_CLUSTER_TMP CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_TMP) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_TMP) LWORK = MAXI_CLUSTER*MAXI_CLUSTER ALLOCATE(RWORK(2*MAXI_CLUSTER),WORK(LWORK),TAU(MAXI_CLUSTER), & JPVT(MAXI_CLUSTER), BLOCKLR(MAXI_CLUSTER,MAXI_CLUSTER), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4) write(6,*) 'ERROR 1 allocate temporary BLR blocks during', & ' ZMUMPS_PROCESS_BLFAC_SLAVE ', IERROR GOTO 700 ENDIF CALL ZMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, & BEGS_BLR_COL, NB_BLR_COL, NPARTSASS_MASTER, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., 0, KEEP(484)) DEALLOCATE(RWORK,WORK,TAU,JPVT,BLOCKLR) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.1.2/src/zana_LDLT_preprocess.F0000664000175000017500000007076613164366265017673 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER N,NCST INTEGER PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N,3) INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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,1) IF(K1 .GT. 0) THEN V1 = (abs(id%A(K1))*(id%ROWSCA(P1)**2).GE.1.0D-1) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2,1) IF(K2 .GT. 0) THEN V2 = (abs(id%A(K2))*(id%ROWSCA(P2)**2).GE.1.0D-1) 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) 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(40) 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) 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.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) 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 & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(40) 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) 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 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE 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 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.1.2/src/mumps_io_basic.h0000664000175000017500000001675513164366240016700 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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) */ /* #define MAX_FILE_SIZE 1000000 */ /* (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.1.2/src/cfac_sol_pool.F0000664000175000017500000004543313164366264016450 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & K28, K76, K80, K47, STEP, INODE) USE CMUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47 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)), & SLAVEF)) & ) 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)), & SLAVEF) ) 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 defined(NOT_ATM_POOL_SPECIAL) J=NBTOP #else 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 #endif DO I=J,1,-1 #if defined(NOT_ATM_POOL_SPECIAL) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE = POOL(LPOOL-2-I) - N ELSE NODE = POOL(LPOOL-2-I) ENDIF #else NODE=POOL(LPOOL-2-I) #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 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ELSEIF(KEEP(81).EQ.3)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) 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)), SLAVEF) ) 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)), & SLAVEF)) 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)), & SLAVEF) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & SLAVEF)) 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GT.0).AND.(INODE.LE.N))THEN #endif 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) #if ! defined(NOT_ATM_POOL_SPECIAL) ELSE ENDIF #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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GT.0).AND.(INODE.LT.N))THEN #endif SBTR_FLAG=(NBINSUBTREE.NE.0) #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #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)), & SLAVEF))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.1.2/src/cfac_front_LU_type1.F0000664000175000017500000005045513164366265017475 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS & , LRGROUPS & ) 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 !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR, NOFFW, NPVW 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) 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 REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVOT_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 CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok INTEGER :: OMP_NUM INCLUDE 'mumps_headers.h' IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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) 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(BEGS_BLR) 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 (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 IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 PIVOT_OPTION = 4 CNT_NODES = CNT_NODES + 1 CALL INIT_STATS_FRONT(NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL INIT_STATS_FRONT(-NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1FR) ENDIF IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL CMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW, & 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 & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( (KEEP(201).EQ.1).AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. (.NOT. COMPRESS_PANEL) .OR. & (KEEP(485).EQ.0) & ) & ) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) END IF 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, .FALSE., .TRUE., & .FALSE. ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) END IF 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, (PIVOT_OPTION.LT.2), .TRUE., & .FALSE. ) ENDIF ELSE CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 1, 0) NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF CALL SYSTEM_CLOCK(T1) IF (IEND_BLR.LT.NFRONT .AND. PIVOT_OPTION.EQ.4) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & -66666, & A, LA, POSELT, .FALSE., .FALSE., & .FALSE. ) ENDIF CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_TRSM_TIME = LOC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR)) ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) IF (IFLAG.LT.0) GOTO 400 CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H', 1) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V', 1) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) END IF IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & . FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF (KEEP(201).EQ.1) 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 IF (COMPRESS_CB) THEN CALL CMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, NPARTSCB+NPARTSASS, & BEGS_BLR, NPARTSCB+NPARTSASS, NPARTSASS, & DKEEP(8), NASS, NFRONT-NASS, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, STEP_STATS(INODE), 1, & .FALSE., 0, KEEP(484)) ENDIF CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NFRONT-NASS, & KEEP(50), INODE, NASS-NPIV) CALL STATS_COMPUTE_FLOP_FRONT_TYPE1(NFRONT, NASS, NPIV, & KEEP(50), INODE) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) DEALLOCATE(WORK) DEALLOCATE(RWORK) DEALLOCATE(TAU) DEALLOCATE(JPVT) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF 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, LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 490 CONTINUE write(*,*) 'Allocation problem in BLR routine & CMUMPS_FAC_FRONT_LU_TYPE1: ', & 'not enough memory? memory requested = ' , IERROR 500 CONTINUE NPVW = NPVW + IW(IOLDPS+1+XSIZE) RETURN END SUBROUTINE CMUMPS_FAC1_LU END MODULE CMUMPS_FAC1_LU_M MUMPS_5.1.2/src/sfac_distrib_distentry.F0000664000175000017500000006407513164366262020410 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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))), & SLAVEF ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & SLAVEF ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & SLAVEF ) 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 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( 40 ), ICNTL(40) 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, INEW, JNEW INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 LOGICAL T4_MASTER_CONCERNED REAL VAL INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE 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 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 IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC) = ZERO ENDDO ENDIF 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) DO K8 = 1_8, NZ_loc8 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, & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF 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) ) CYCLE 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 (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 ENDIF ENDIF IARR = abs( ISEND ) ISTEP = abs(STEP(IARR)) TYPE_NODE = MUMPS_TYPENODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE= MUMPS_PROCNODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & SLAVEF ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF (TYPE_NODE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF ELSE 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 END IF if (DEST .eq. -1) 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 end if IF ( DEST.EQ.-1) THEN DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDDO 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, ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDIF ELSE 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, ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDIF ENDIF END DO DEST = -2 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, ARROW_ROOT, 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, & ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, & KEEP,KEEP8 ) IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER ARROW_ROOT, 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. -2 ) 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. -2 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -2 .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, & ARROW_ROOT, 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. -2 ) 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, & ARROW_ROOT, 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, ARROW_ROOT, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER NBRECORDS, N, ARROW_ROOT, 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, IROW_GRID, JCOL_GRID, & ILOCROOT, JLOCROOT INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT, IARR, JARR INTEGER TAILLE REAL VAL 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 )))), & SLAVEF ) IF ( NODE_TYPE .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .NE. root%MYROW .OR. & JCOL_GRID .NE. root%MYCOL ) THEN WRITE(*,*) MYID,':INTERNAL Error: recvd root arrowhead ' WRITE(*,*) MYID,':not belonging to me. IARR,JARR=',IARR,JARR WRITE(*,*) MYID,':IROW_GRID,JCOL_GRID=',IROW_GRID,JCOL_GRID WRITE(*,*) MYID,':MYROW, MYCOL=', root%MYROW, root%MYCOL WRITE(*,*) MYID,':IPOSROOT,JPOSROOT=', IPOSROOT, JPOSROOT CALL MUMPS_ABORT() 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 IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) & .AND. & IW4(IARR,1) .EQ. 0 .AND. & IPROC .EQ. MYID & .AND. STEP(IARR) > 0 ) 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 ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE SMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.1.2/src/sfac_process_bf.F0000664000175000017500000000071313164366262016755 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE SMUMPS_PROCESS_BF_RETURN MUMPS_5.1.2/src/dfac_scalings.F0000664000175000017500000002752313164366263016425 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), INFO(40) 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(OUT) :: 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.1.2/src/csol_fwd.F0000664000175000017500000001217113164366264015437 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, & NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, 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_OOC IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB, LNA INTEGER SLAVEF, MYLEAF, COMM, MYID INTEGER INFO( 40 ), 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 NA( LNA ), NE_STEPS( KEEP(28) ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK_S(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 #if defined(RHSCOMP_BYROWS) COMPLEX, intent(inout) :: RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX, intent(inout) :: RHSCOMP(LRHSCOMP,NRHS) #endif LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGSOU, DUMMY(1) LOGICAL FLAG INTEGER NBFIN, MYROOT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE INTEGER I INTEGER III, NBROOT,LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 DO I = 1, KEEP(28) NSTK_S(I) = NE_STEPS(I) ENDDO PTRICB = 0 CALL MUMPS_INIT_POOL_DIST(N, LEAF, MYID, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID, & SLAVEF, NA, LNA, KEEP, STEP, & PROCNODE_STEPS) NBFIN = SLAVEF IF ( MYROOT .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 MYLEAF = LEAF - 1 III = 1 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, III, 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 .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_SOLVE_NODE( INODE, BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, III, 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, & MYROOT, INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 .OR. 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.1.2/src/zmumps_save_restore_files.F0000664000175000017500000000071313164366266021136 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE ZMUMPS_SAVE_FILES_RETURN MUMPS_5.1.2/src/zmumps_comm_buffer.F0000664000175000017500000035772413164366265017557 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 :: 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 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 ) 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) 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 INCLUDE 'mpif.h' INTEGER :: IERR 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) 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 ) CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), IERR ) 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, COMPRESSCB, & 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 COMPRESSCB INCLUDE 'mpif.h' 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) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR) 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 (COMPRESSCB) 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 (COMPRESSCB) 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 ) 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 ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (COMPRESSCB) 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 ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (COMPRESSCB) 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 ) 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 ) 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 ) 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 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 ) 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 ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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 ) ) # if defined(RHSCOMP_BYROWS) COMPLEX(kind=8) RHSCOMP(NRHS,LRHSCOMP) # else COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) # endif INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' 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 ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR ) 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 ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) IF (NODE2.EQ.0.AND.KEEP(350).NE.0) THEN DO K=1, NRHS_B #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in ZMUMPS_BUF_SEND_VCB" CALL MUMPS_ABORT() #else 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 ) 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 ) ENDIF #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 ) 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 ) 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 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 ) 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 ) KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR ) 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 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 ) 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 :: 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 ) 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, & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , LRSTATUS &) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER INODE INTEGER NLIG, NCOL, NASS, NSLAVES 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 SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE_INT = ( 7 + NLIG + NCOL + NSLAVES + 1 ) SIZE_INT = SIZE_INT + 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 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 ) 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 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 ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR) 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 ) 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 ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & COMPRESSCB, KEEP253_LOC ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC INTEGER IPERE, ISON, NBROW 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( * ) LOGICAL DESC_IN_LU, COMPRESSCB 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 NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX INTEGER NBROWS_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: SIZFR, ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, 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) PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO = 0.0D0) 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) CALL MUMPS_GETI8( SIZFR, IW_CBSON( 1 + XXR ) ) 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, PS1, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_DOUBLE_PRECISION, & COMM, SIZE1, IERR ) ENDIF SIZE1 = SIZE1+PS1 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 CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR ) 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, & min( NBROWS_PACKET, NBROW - NBROWS_ALREADY_SENT)) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET * LROW ELSE SIZE_REALS = ( LROW + PERM(1) + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET + ( NBROWS_PACKET * ( NBROWS_PACKET + 1) ) / 2 MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET CALL MPI_PACK_SIZE( SIZE_REALS, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR) IF (SIZE2 + SIZE3 .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 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) & 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 ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) ENDDO 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 ) ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( COMPRESSCB ) 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 ( COMPRESSCB ) 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 ) ENDDO 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 ) IF(NFS4FATHER .GT. 0) THEN 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 (COMPRESSCB) 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 (COMPRESSCB) 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 = SIZFR - (SHIFTCB_SON - & int(PS1-1,8) * LDA_SON8) LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC .NE. 0 ) THEN CALL ZMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC, & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 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 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 ) 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 ) 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, & SEND_LR, 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) :: SEND_LR INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER :: SEND_LR_INT INTEGER, intent(inout) :: IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' 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 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 ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR ) 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 ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF END IF SIZE2 = 0 CALL MPI_PACK_SIZE(4, MPI_INTEGER, COMM, SIZE3, IERR) SIZE2=SIZE2+SIZE3 IF ( KEEP(50).NE.0 ) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, COMM, SIZE3, IERR) SIZE2=SIZE2+SIZE3 ENDIF IF ((NPIV.GT.0) & ) THEN IF (.NOT. SEND_LR) THEN CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_DOUBLE_COMPLEX, & COMM, SIZE3, IERR ) SIZE2 = SIZE2+SIZE3 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), MPI_DOUBLE_COMPLEX, & COMM, SIZE3, IERR ) 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 ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) 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 ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( LASTBL .or. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) THEN SEND_LR_INT=1 ELSE SEND_LR_INT=0 ENDIF CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) ENDIF IF (SEND_LR) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) END DO CALL MUMPS_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 ) END DO ENDIF ENDIF CALL MPI_PACK( LRELAY_INFO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( LRELAY_INFO.GT.0) & CALL MPI_PACK( RELAY_INFO, LRELAY_INFO, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) 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 ) 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, & SEND_LR, 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) :: SEND_LR 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) INTEGER :: SEND_LR_INT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' 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 ) SIZE2 = 0 CALL MPI_PACK_SIZE(2, MPI_INTEGER, COMM, SSLR, IERR) SIZE2=SIZE2+SSLR IF (.NOT. SEND_LR) THEN CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_DOUBLE_COMPLEX, & COMM, SSLR, IERR ) 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 ) 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 ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) THEN SEND_LR_INT=1 ELSE SEND_LR_INT=0 ENDIF CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) 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 ) 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 ) 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, DIMENSION(:) :: RG2L_ROW INTEGER, DIMENSION(:) :: RG2L_COL 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 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 ) 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) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_DOUBLE_COMPLEX, COMM, & SIZE_TMP, IERR) 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 ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR ) 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 ! defined(DBG_SMB3) 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 #endif ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR ) 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 ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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.1.2/src/clr_core.F0000664000175000017500000007701513164366266015441 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE CMUMPS_LR_CORE USE MUMPS_LR_COMMON USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,KSVD,M,N,ISLR) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,KSVD,M,N LOGICAL,INTENT(IN) :: ISLR C This routine simply initializes a LR block but does NOT allocate it LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%KSVD = KSVD LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) IF (ISLR) THEN LRB_OUT%LRFORM = 1 ELSE LRB_OUT%LRFORM = 0 ENDIF END SUBROUTINE INIT_LRB SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS, K486, K489, & K490, K491, K492, N, LRGROUPS, LRSTATUS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, K486, K489, K490, & K491, K492 INTEGER,INTENT(IN) :: N, LRGROUPS(N) INTEGER,INTENT(OUT):: LRSTATUS C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB COMPRESS_PANEL = .FALSE. IF ((K486.GT.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.EQ.1) COMPRESS_PANEL =.FALSE. IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF COMPRESS_CB = .FALSE. IF ((K492.GT.0).AND.(K489.EQ.1).AND.(NFRONT-NASS.GT.K491)) THEN COMPRESS_CB = .TRUE. ENDIF 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 END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,KSVD,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,KSVD,M,N INTEGER,INTENT(OUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok COMPLEX :: ZERO PARAMETER (ZERO=(0.0E0,0.0E0)) 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) write(*,*) 'Allocation problem in BLR routine ALLOC_LRB:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF ENDIF ELSE allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N write(*,*) 'Allocation problem in BLR routine ALLOC_LRB:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF nullify(LRB_OUT%R) ENDIF LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%KSVD = KSVD LRB_OUT%ISLR = ISLR IF (ISLR) THEN LRB_OUT%LRFORM = 1 ELSE LRB_OUT%LRFORM = 0 ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF KEEP8(70) = KEEP8(70) - int(MEM,8) KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - int(MEM,8) KEEP8(69) = min(KEEP8(71), KEEP8(69)) END SUBROUTINE ALLOC_LRB 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 LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2 ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1)) 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)) DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE CMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, POSELTD, & 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_LRGEMM3) 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) :: POSELTD, POSELTT INTEGER, INTENT(IN) :: MAXI_CLUSTER COMPLEX, intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS COMPLEX :: PIV1, PIV2, OFFDIAG IF (LRB%LRFORM.EQ.1) THEN NROWS = LRB%K ELSE ! Full Rank Block NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot 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: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_LRGEMM3(TRANSB1, TRANSB2, ALPHA, & LRB1, LRB2, BETA, A, LA, POSELTT, NFRONT, SYM, NIV, & IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, RANK, BUILDQ, & POSELTD, LD_DIAG, IW2, BLOCK, MAXI_CLUSTER) TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, NIV INTEGER,INTENT(OUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8), INTENT(IN), OPTIONAL :: POSELTD INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER CHARACTER(len=1),INTENT(IN) :: TRANSB1, TRANSB2 INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT REAL, intent(in) :: TOLEPS COMPLEX :: ALPHA,BETA COMPLEX, intent(inout), OPTIONAL :: BLOCK(:) COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: XY_YZ COMPLEX, ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y COMPLEX, POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSX, TRANSY, TRANSZ INTEGER :: M_X, K_XY, K_YZ, N_Z, LDX, LDY, LDY1, LDY2, LDZ, K_Y INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK LOGICAL :: BUILDQ REAL, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: T1, T2, CR INTEGER :: allocok, MREQ DOUBLE PRECISION :: LOC_UPDT_TIME_OUT 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 (LRB2%M.EQ.0) THEN write(*,*) "Internal error in CMUMPS_LRGEMM3, LRB2%M=0" CALL MUMPS_ABORT() ENDIF IF ((SYM.NE.0).AND.((TRANSB1.NE.'N').OR.(TRANSB2.NE.'T'))) THEN WRITE(*,*) "SYM > 0 and (", TRANSB1, ",", TRANSB2, & ") parameters found. Symmetric LRGEMM is only ", & "compatible with (N,T) parameters" CALL MUMPS_ABORT() ENDIF RANK = 0 BUILDQ = .FALSE. IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==1)) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) GOTO 700 allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 860 ENDIF IF (TRANSB1 == 'N') THEN X => LRB1%Q LDX = LRB1%M M_X = LRB1%M 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K ELSE !TRANSB1 == 'T' M_X = LRB1%N X => LRB1%R LDX = LRB1%K K_Y = LRB1%M Y1 => LRB1%Q LDY1 = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN Z => LRB2%R LDZ = LRB2%K N_Z = LRB2%N Y2 => LRB2%Q LDY2 = LRB2%M ELSE !TRANSB2 == 'T' N_Z = LRB2%M Z => LRB2%Q LDZ = LRB2%M Y2 => LRB2%R LDY2 = LRB2%K ENDIF TRANSZ = TRANSB2 CALL cgemm(TRANSB1 , TRANSB2 , LRB1%K , LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) BUILDQ = .FALSE. IF (COMPRESS_MID_PRODUCT.GE.1) THEN LWORK = MAX(LRB2%K**2, M_X**2) 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 860 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(1), TAU_RRQR(1), WORK_RRQR(1), & LRB2%K, RWORK_RRQR(1), TOLEPS, RANK, MAXRANK, INFO) IF ((RANK.GT.MAXRANK).OR.(RANK.EQ.0)) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN ! Successfully compressed middle block allocate(XQ(M_X,RANK), R_Y(RANK,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = M_X*RANK + RANK*LRB2%K GOTO 860 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 CALL cungqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL cgemm(TRANSB1, 'N', M_X, RANK, LRB1%K, ONE, & X(1,1), LDX, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), M_X) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ LDX = M_X K_XY = RANK TRANSX = 'N' deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSX = TRANSB1 TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE ! LRB1%K < LRB2%K SIDE = 'R' ENDIF ENDIF ENDIF IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN IF (LRB1%K.EQ.0) GOTO 700 SIDE = 'R' K_XY = LRB1%K TRANSX = TRANSB1 TRANSY = TRANSB1 Z => LRB2%Q LDZ = LRB2%M TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN X => LRB1%Q LDX = LRB1%M M_X = LRB1%M 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF ELSE ! TRANSB1 == 'T' X => LRB1%R LDX = LRB1%K M_X = LRB1%N Y => LRB1%Q LDY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN K_YZ = LRB2%M N_Z = LRB2%N ELSE ! TRANSB2 == 'T' K_YZ = LRB2%N N_Z = LRB2%M ENDIF ENDIF IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN IF (LRB2%K.EQ.0) GOTO 700 SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q LDX = LRB1%M TRANSX = TRANSB1 TRANSY = TRANSB2 TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN M_X = LRB1%M K_XY = LRB1%N ELSE ! TRANSB1 == 'T' M_X = LRB1%N K_XY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN Y => LRB2%Q LDY = LRB2%M Z => LRB2%R LDZ = LRB2%K N_Z = LRB2%N ELSE ! TRANSB2 == 'T' IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE ! Symmetric case: column scaling of R2 is done allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q LDZ = LRB2%M N_Z = LRB2%M ENDIF ENDIF IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' LDX = LRB1%M TRANSX = TRANSB1 Z => LRB2%Q LDZ = LRB2%M TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN M_X = LRB1%M K_XY = LRB1%N ELSE ! TRANSB1 == 'T' M_X = LRB1%N K_XY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN N_Z = LRB2%N ELSE ! TRANSB2 == 'T' N_Z = LRB2%M ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z allocate(XY_YZ(M_X,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = M_X*K_YZ GOTO 860 ENDIF CALL cgemm(TRANSX , TRANSY , M_X , K_YZ, K_XY, ONE, & X(1,1), LDX, Y(1,1), LDY, ZERO, XY_YZ(1,1), M_X) CALL SYSTEM_CLOCK(T1) CALL cgemm('N', TRANSZ, M_X, N_Z, K_YZ, ALPHA, & XY_YZ(1,1), M_X, Z(1,1), LDZ, BETA, A(POSELTT), & NFRONT) CALL SYSTEM_CLOCK(T2,CR) LOC_UPDT_TIME_OUT = dble(T2-T1)/dble(CR) CALL UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) deallocate(XY_YZ) ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ allocate(XY_YZ(K_XY,N_Z),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*N_Z GOTO 860 ENDIF CALL cgemm(TRANSY , TRANSZ , K_XY , N_Z, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LDZ, ZERO, XY_YZ(1,1), K_XY) CALL SYSTEM_CLOCK(T1) CALL cgemm(TRANSX, 'N', M_X, N_Z, K_XY, ALPHA, & X(1,1), LDX, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) CALL SYSTEM_CLOCK(T2,CR) LOC_UPDT_TIME_OUT = dble(T2-T1)/dble(CR) CALL UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) deallocate(XY_YZ) ELSE ! SIDE == 'N' : NONE; A = X*Z CALL cgemm(TRANSX, TRANSZ, M_X, N_Z, K_XY, ALPHA, & X(1,1), LDX, Z(1,1), LDZ, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 870 860 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine CMUMPS_LRGEMM3: ', & 'not enough memory? memory requested = ' , MREQ IFLAG = - 13 IERROR = MREQ RETURN 870 CONTINUE C Alloc ok!! IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE ! 1 AND 1 IF ((TRANSB1=='N').AND.(SYM .NE. 0)) deallocate(Y1) IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 700 CONTINUE END SUBROUTINE CMUMPS_LRGEMM3 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 END MODULE CMUMPS_LR_CORE SUBROUTINE CMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, 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 The authors of the LAPACK library are: C - Univ. of Tennessee C - Univ. of California Berkeley C - Univ. of Colorado Denver C - NAG Ltd. IMPLICIT NONE INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK REAL :: TOLEPS INTEGER :: JPVT(*) REAL :: RWORK(*) COMPLEX :: A(LDA,*), TAU(*) COMPLEX :: WORK(LDW,*) 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 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 CALL XERBLA( 'CGEQP3', -INFO ) RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RETURN END IF NB = ILAENV( INB, 'CGEQRF', ' ', M, N, -1, -1 ) 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 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 ) C IF(VN1(PVT).LT.TOLEPS) THEN IF(RWORK(PVT).LT.TOLEPS) 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 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 END DO RANK = RK END SUBROUTINE CMUMPS_TRUNCATED_RRQR MUMPS_5.1.2/src/dfac_root_parallel.F0000664000175000017500000001517613164366263017462 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_FACTO_ROOT( 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) USE DMUMPS_LR_STATS, ONLY: UPDATE_FLOPS_STATS_ROOT IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' TYPE ( DMUMPS_ROOT_STRUC ) :: root 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 IOLDPS INTEGER(8) :: IAPOS 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 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 UPDATE_FLOPS_STATS_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 UPDATE_FLOPS_STATS_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,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 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, DKEEP(6), KEEP(259), & 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.1.2/src/cfac_process_contrib_type2.F0000664000175000017500000003400413164366264021133 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ), FILS( N ) 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 'mumps_headers.h' 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 #if ! defined(NO_XXNBPR) INTEGER :: INBPROCFILS_SON #endif 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 ) MASTER = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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) 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 ) CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN 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 ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress CMUMPS_PROCESS_CONTRIB_TYPE2' WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR( LREQA - LRLUS, IERROR ) CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END IF END IF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQA KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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 NBPROCFILS(STEP(INODE))=NBPROCFILS(STEP(INODE))-NBROW #if ! defined(NO_XXNBPR) IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW #endif 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 ) 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 ) 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 CALL CMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ELSE 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 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 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - DECR NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB #if ! defined(NO_XXNBPR) 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 #endif #if ! defined(NO_XXNBPR) IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN #endif 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_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF #if ! defined(NO_XXNBPR) IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN #else IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN #endif CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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.1.2/src/dfac_front_aux.F0000664000175000017500000020456413164366264016632 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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,IOLDPS,POSELT,UU,SEUIL,KEEP, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER KEEP(500) 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 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 NOFFW,NPIV,IPIV,IPIV_SHIFT 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 !$ INTEGER :: JJMAX !$ DOUBLE PRECISION :: RRMAX, VALABS !$ INTEGER :: NOMP, CHUNK, K360 !$ K360 = KEEP(360) !$ NOMP = OMP_GET_MAX_THREADS() NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) 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)).GT.max(UU*MAXFROMN,SEUIL, & tiny(MAXFROMN))) 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 IF (KEEP(351).EQ.1) THEN !$ IF (NOMP.GT.1 .AND. J3.GE.K360) THEN !$ JMAX = 1 !$ RMAX = RZERO !$ CHUNK = max(K360/2,J3/NOMP) !$OMP PARALLEL PRIVATE(JJ,VALABS,JJMAX,RRMAX) !$OMP& FIRSTPRIVATE(J1,NFRONT8,J3) !$ RRMAX = RZERO !$OMP DO schedule(static, CHUNK) !$ DO J = 1, J3 !$ JJ = J1 + int(J-1,8)*NFRONT8 !$ VALABS = abs(A(JJ)) !$ IF (VALABS.GT.RRMAX) THEN !$ RRMAX = VALABS !$ JJMAX = J !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (RRMAX.GT.0.0) THEN !$OMP CRITICAL !$ IF (RRMAX.GT.RMAX) THEN !$ RMAX = RRMAX !$ JMAX = JJMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE JMAX = DMUMPS_IXAMAX(J3,A(J1),NFRONT) !$ ENDIF ELSE JMAX = DMUMPS_IXAMAX(J3,A(J1),NFRONT) ENDIF 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) 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) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(J1) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) IF (J3.GE.K360) DO J=1,J3 J1 = J1_ini + int(J-1,8) * NFRONT8 RMAX = max(abs(A(J1)),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)).GT.max(UU*RMAX,SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE.max(UU*RMAX,SEUIL,tiny(RMAX))) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DKEEP(6), & KEEP(259) ) ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 KEEP(260)=-KEEP(260) 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 KEEP(260)=-KEEP(260) 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 (KEEP(201).EQ.1) 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) !$ 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 NEL,IROW,NEL2,JCOL, NCB INTEGER NPIVP1 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 !$ LOGICAL:: OMP_FLAG !$ INTEGER:: NOMP, K360, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ K360 = KEEP(360) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NEL2 = NASS - NPIVP1 NCB = NFRONT - NASS - KEEP(253) IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) !$ OMP_FLAG = .FALSE. !$ CHUNK = NEL !$ 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) !$ ENDIF !$ ELSE !$ OMP_FLAG = .TRUE. !$ CHUNK = max(K360/2,NEL/NOMP) !$ 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) 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_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM & ) IMPLICIT NONE INTEGER(8) :: LA,POSELT DOUBLE PRECISION A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL CALL_UTRSM INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1,NEL11 DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) CALL dtrsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_UTRSM) THEN UPOS = POSELT + int(NASS,8) CALL dtrsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) CALL dgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE DMUMPS_FAC_P SUBROUTINE DMUMPS_FAC_P_PANEL(A,LAFAC,NFRONT, & NPIV,NASS, IW, LIWFAC, & MonBloc, TYPEFile, MYID, KEEP8, & STRAT, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten) USE DMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NPIV, NASS INTEGER(8) :: LAFAC INTEGER LIWFAC, TYPEFile, MYID, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten, STRAT DOUBLE PRECISION A(LAFAC) INTEGER IW(LIWFAC) INTEGER(8) KEEP8(150) TYPE(IO_BLOCK) :: MonBloc INTEGER(8) :: LPOS2,LPOS1,LPOS INTEGER NEL1,NEL11 DOUBLE PRECISION ALPHA, ONE LOGICAL LAST_CALL PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = 1_8 + int(NASS,8) * int(NFRONT,8) CALL dtrsm('L','L','N','N',NPIV,NEL1,ONE,A(1),NFRONT, & A(LPOS2),NFRONT) LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) LPOS = LPOS2 + int(NPIV,8) LPOS1 = int(1 + NPIV,8) CALL dgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE DMUMPS_FAC_P_PANEL 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, & CALL_UTRSM, CALL_GEMM, WITH_COMM_THREAD ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD INTEGER(8) :: NFRONT8 INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER NELIM, LKJIW, NEL1, NEL11 DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) 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 IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + & int(IEND_BLOCK,8) POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*NFRONT8 + int(IBEG_BLOCK - 1,8) CALL dtrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) IF (CALL_UTRSM) THEN CALL dtrsm('R','U','N','U',NEL1,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),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 ENDIF RETURN END SUBROUTINE DMUMPS_FAC_SQ SUBROUTINE DMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB) 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) 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, LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG) USE DMUMPS_OOC IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW, & 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) TYPE(IO_BLOCK), intent(inout) :: MonBloc INTEGER :: NPIV, NEL1, STRAT, TYPEFile, IFLAG_OOC, & 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 (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_BOTH_LU MonBloc%LastPiv= NPIV CALL DMUMPS_FAC_P_PANEL(A(POSELT), LAFAC, NFRONT, & NPIV, NASS, IW(IOLDPS), LIWFAC, & MonBloc, TYPEFile, MYID, KEEP8, & STRAT, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC ELSE CALL DMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM & ) ENDIF 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,IOLDPS,POSELT,UU,SEUIL, & KEEP, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv & ) IF (INOPV.NE.1) THEN CALL DMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL) 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,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, & 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 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 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 DOUBLE PRECISION PIVNUL DOUBLE PRECISION FIXA, CSEUIL INTEGER NPIV,IPIV INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF INTEGER DMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0D0/ !$ INTEGER :: J4,JJMAX,NOMP,CHUNK,K361 !$ DOUBLE PRECISION :: RRMAX,VALABS INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U !$ NOMP = OMP_GET_MAX_THREADS() !$ K361 = KEEP(361) 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 IF (KEEP(201).EQ.1) 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 IF(abs(A(APOS)).LT.SEUIL) THEN IF (dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF KEEP(98) = KEEP(98)+1 ELSE IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1) 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.GT.0.AND.UU.GT.RZERO) GO TO 340 IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 340 CONTINUE 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 IF (KEEP(351).EQ.1) THEN !$ IF (NOMP.GT.1 .AND. J.GE.K361) THEN !$ JMAX = 1 !$ RMAX = RZERO !$ CHUNK = max(K361/2,J/NOMP) !$OMP PARALLEL PRIVATE(J3,VALABS,JJMAX,RRMAX) !$OMP& FIRSTPRIVATE(J1,J) !$ RRMAX = RZERO !$OMP DO schedule(static, CHUNK) !$ DO J4 = 1, J !$ J3 = J1 + int(J4-1,8) !$ VALABS = abs(A(J3)) !$ IF(VALABS.GT.RRMAX) THEN !$ RRMAX = VALABS !$ JJMAX = J4 !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (RRMAX.GT.0.0) THEN !$OMP CRITICAL !$ IF (RRMAX.GT.RMAX) THEN !$ RMAX = RRMAX !$ JMAX = JJMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE JMAX = DMUMPS_IXAMAX(J,A(J1),1) !$ ENDIF ELSE JMAX = DMUMPS_IXAMAX(J,A(J1),1) ENDIF 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),8) ELSE J2 = APOS +int(- NPIV + NASS - 1 - KEEP(253),8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1) THEN !$ CHUNK = max(K361/2,int(J2-J1)/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 ENDIF 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF ( RMAX .LE. PIVNUL ) THEN 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(LAST_ROW-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LAST_ROW-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO KEEP(109) = KEEP(109)+1 ISW = IOLDPS+HF+ & IW(IOLDPS+1+XSIZE)+IPIV-NPIVP1 PIVNUL_LIST(KEEP(109)) = IW(ISW) 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 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 IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DKEEP(6), & KEEP(259)) ENDIF 385 CONTINUE IF (IPIV.EQ.NPIVP1) GO TO 400 KEEP(260)=-KEEP(260) 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 KEEP(260)=-KEEP(260) 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 (KEEP(201).EQ.1) 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, & NNEG, & 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,INODE,IFLAG,INOPV, & IOLDPS, NNEG INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv 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 include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM DOUBLE PRECISION RMAX,AMAX,TMAX DOUBLE PRECISION MAXPIV DOUBLE PRECISION PIVNUL DOUBLE PRECISION FIXA, CSEUIL DOUBLE PRECISION PIVOT,DETPIV INCLUDE 'mumps_headers.h' 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) LOGICAL OMP_FLAG INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEG = NNEG+1 ENDIF KEEP(98) = KEEP(98)+1 ELSE IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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) NNEG = NNEG+1 IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) 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) NNEG = NNEG+1 IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. 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 + 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 IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSEIF (PIVOT_OPTION.EQ.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT: PIVOT_OPTION=', & PIVOT_OPTION ENDIF J1_ini = J1 IF ( (LIM - KEEP(253) - IEND_BLOCK).GE.300 ) THEN OMP_FLAG = .TRUE. ELSE OMP_FLAG = .FALSE. ENDIF !$OMP PARALLEL DO PRIVATE(J1) REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - KEEP(253) - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN KEEP(109) = KEEP(109)+1 PIVNUL_LIST(KEEP(109)) = -1 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,NFRONT - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN IF (PIVOT .LT. ZERO) NNEG = NNEG+1 IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) 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,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSEIF (PIVOT_OPTION.EQ.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT: PIVOT_OPTION=', & PIVOT_OPTION 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 (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 OMP_FLAG = (LIM-JMAX-KEEP(253). GE. 300) !$OMP PARALLEL DO IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX - KEEP(253) 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_FLAG = (LIM-JMAX-KEEP(253). GE. 300) !$OMP PARALLEL DO PRIVATE(JJ) REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX-KEEP(253) 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 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 IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(103) = KEEP(103)+1 IF(DETPIV .LT. RZERO) THEN NNEG = NNEG+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEG = NNEG+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 CALL DMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDA, NFRONT, 1, KEEP(219), KEEP(50), & KEEP(IXSZ), -9999) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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, & KEEP253, PIVOT_OPTION, IEND_BLR & ) 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) :: PIVOT_OPTION, 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) :: KEEP253 DOUBLE PRECISION VALPIV DOUBLE PRECISION :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2, NEL, LIM 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 DOUBLE PRECISION SWOP,DETPIV,MULT1,MULT2 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 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 MAXFROMM = 0.0D00 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 IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSE LIM = IEND_BLR ENDIF NCB1 = LIM - IEND_BLOCK 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 - KEEP253 > 300) DO I=NEL2+1, NEL2 + NCB1 - KEEP253 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 - KEEP253 + 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 ELSE IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSE LIM = IEND_BLR ENDIF 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(LIM-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL dcopy(LIM-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 DO J2 = IEND_BLOCK+1,LIM 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 JJ = JJ + NFRONT8 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_FAC_MQ_LDLT SUBROUTINE DMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,LAST_VAR,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & PIVOT_OPTION, CALL_TRSM) 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, intent(in) :: LAST_VAR INTEGER :: KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: PIVOT_OPTION LOGICAL, intent(in) :: CALL_TRSM INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1, I, II INTEGER(8) :: LPOS,UPOS,APOS INTEGER IROW INTEGER Block INTEGER BLSIZE, ELSIZE DOUBLE PRECISION ONE, ALPHA, VALPIV INCLUDE 'mumps_headers.h' PARAMETER (ONE=1.0D0, ALPHA=-1.0D0) LDA8 = int(LDA,8) ELSIZE = IEND_BLOCK - IBEG_BLOCK +1 NEL1 = LAST_VAR - IEND_BLOCK NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (PIVOT_OPTION.LE.1.AND.CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) CALL dtrsm('L', 'U', 'T', 'U', ELSIZE, NEL1, ONE, & A(APOS), LDA, A(LPOS), LDA) !$OMP PARALLEL PRIVATE(VALPIV,I,II) DO I = 1, ELSIZE VALPIV = ONE/A(POSELT+(LDA8+1_8)*int(IBEG_BLOCK+I-2,8)) !$OMP DO DO II = 1,NEL1 A(UPOS+int(I-1,8)*LDA8 + int(II-1,8)) = & A(LPOS+int(I-1,8) + int(II-1,8)*LDA8) A(LPOS+int(I-1,8) + int(II-1,8)*LDA8) = & A(LPOS+int(I-1,8) + int(II-1,8)*LDA8)*VALPIV ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ENDIF IF ( LAST_VAR - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_VAR - IEND_BLOCK END IF IF ( NASS - IEND_BLOCK .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = IEND_BLOCK+1, LAST_VAR, BLSIZE Block = min( BLSIZE, NASS - 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_VAR, BLSIZE Block = min( BLSIZE, LAST_VAR - 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_VAR - IROW + 1, NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF LPOS = POSELT + int(LAST_VAR,8)*LDA8 + int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_VAR,8)*LDA8 + int(IEND_BLOCK,8) IF (PIVOT_OPTION.EQ.3) THEN CALL dgemm('N', 'N', NEL1, NFRONT-LAST_VAR, NPIV_BLOCK, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) ELSEIF (PIVOT_OPTION.EQ.2.AND.(NASS.GT. LAST_VAR)) THEN CALL dgemm('N', 'N', NEL1, NASS-LAST_VAR, NPIV_BLOCK, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_SQ_LDLT SUBROUTINE DMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, NASS, & LDA, NFRONT, LEVEL, K219, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, NASS, LEVEL, K219, K50, XSIZE DOUBLE PRECISION A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: LASTROW2SWAP, 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 IF (LEVEL .EQ. 1) THEN LASTROW2SWAP = NFRONT ELSE LASTROW2SWAP = NASS ENDIF CALL dswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF (K219.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2) 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_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) 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 INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, I, J, IROWEND INTEGER I2, I2END, Block2 DOUBLE PRECISION ONE, ALPHA, BETA, ZERO DOUBLE PRECISION :: MULT1, MULT2, A11, DETPIV, A22, A12 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(57) ) THEN BLSIZE = KEEP(58) 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 CALL dtrsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NPIV, ONE, & A( POSELT ), LDA, & A( POSELT + LDA8 * int(NPIV,8) ), LDA ) 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 DPOS = POSELT I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN A11 = ONE/A(DPOS) CALL dcopy(Block, A(LPOS+int(I-1,8)), LDA, & A(UPOS+int(I-1,8)*LDA8), 1) CALL dscal(Block, A11, A(LPOS+int(I-1,8)), LDA) DPOS = DPOS + int(LDA+1,8) I = I+1 ELSE CALL dcopy(Block, A(LPOS+int(I-1,8)), LDA, & A(UPOS+int(I-1,8)*LDA8), 1) CALL dcopy(Block, A(LPOS+int(I,8)), LDA, & A(UPOS+int(I,8)*LDA8), 1) 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,Block 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 DPOS = POSPV2 + int(LDA+1,8) I = I+2 ENDIF ENDDO 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 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 END MODULE DMUMPS_FAC_FRONT_AUX_M MUMPS_5.1.2/src/dfac_process_blocfacto_LDLT.F0000664000175000017500000010630213164366263021124 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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_OOC USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_FAC_LR USE DMUMPS_ANA_LR USE DMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ), 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), 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 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL, LD_BLOCFACTO INTEGER(8) LAELL, POSBLOCFACTO INTEGER(8) POSELT 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 INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW LOGICAL LASTBL INTEGER SRC_DESCBAND LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION ONE,ALPHA PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPivDummy LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRELAY_INFO LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR LOGICAL :: SEND_LR INTEGER :: XSIZE, CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: SEND_LR_INT, 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 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL 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 INTEGER T1, T2, COUNT_RATE, LWORK DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, MY_NUM 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF 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 ( SEND_LR ) THEN LAELL = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LAELL = int(NPIV,8) * int(NCOL,8) ENDIF IF ( NPIV.GT.0 ) THEN IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS, IERROR) IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN DMUMPS_PROCESS_SYM_BLOCFACTO, & REAL WORKSPACE TOO SMALL" GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress DMUMPS_PROCESS_SYM_BLOCFACTO,", & " LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS,IERROR) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN DMUMPS_PROCESS_SYM_BLOCFACTO, & INTEGER WORKSPACE TOO SMALL" IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(70) = KEEP8(70) - LAELL KEEP8(71) = KEEP8(71) - LAELL ENDIF KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLUS) IF ( NPIV.EQ.0 ) THEN IPIV = 1 LD_BLOCFACTO = NPIV+NELIM ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR ) 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_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1))) ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2)) CALL DMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, KEEP(470), & BEGS_BLR_LM(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 SRC_DESCBAND = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTRIST(STEP(INODE))+XXNBPR)) DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) #else DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) POSELT = PTRAST(STEP(INODE)) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) ELSE CALL DMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS) 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 PIVI = abs(IW(IPIV+I-1)) 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(IPOS), NCOL1, A(KPOS), NCOL1) ENDDO IF (.NOT.SEND_LR) 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 (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T1) ENDIF CALL dtrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A(POSELT+int(NPIV1,8)), NCOL1 ) IF (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_TRSM_TIME = ACC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF IF (.NOT.SEND_LR) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 DO I = 1, NROW1 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = & A(LPOS: LPOS+int(NPIV-1,8)) LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF LPOS = POSELT + int(NPIV1,8) DPOS = POSBLOCFACTO I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(IPIV+I-1) .GT. 0) THEN A11 = ONE/A(DPOS) CALL dscal( NROW1, A11, A(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 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A11*A(LPOS1)+A12*A(LPOS1+1_8) MULT2 = A12*A(LPOS1)+A22*A(LPOS1+1_8) A(LPOS1) = MULT1 A(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 IF (SEND_LR) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 ENDIF IF (NPIV.GT.0) THEN IF (NROW1.LE.0) CALL MUMPS_ABORT() IF (SEND_LR) 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 (KEEP(489).EQ.1) 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 ELSE CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_MASTER ENDIF CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL) 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 CALL DMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), & .TRUE., .TRUE., .TRUE., NPARTSASS_MASTER, & 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)) write(6,*) 'ERROR 2 allocate temporary BLR blocks during', & ' DMUMPS_PROCESS_SYM_BLOCFACTO', IERROR GOTO 700 ENDIF CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS)) CALL SYSTEM_CLOCK(T1) MY_NUM=0 #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, DKEEP(8), KEEP(473), BLR_LS, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #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. & ( .NOT. SEND_LR .OR. (NPIV.EQ.0) .OR. & (KEEP(485).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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN IF (SEND_LR) THEN IF (NELIM.GT.0) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL dgemm('N','N', NELIM,NROW1,NPIV,ALPHA, & A(UPOS),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ENDIF #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL DMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL1, NROW1, & POSBLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM+1, BLR_LM, NPIV1, & BEGS_BLR_LS, NB_BLR_LS+1, BLR_LS, 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR(1:MAXI_CLUSTER,MY_NUM*MAXI_CLUSTER+1), & MAXI_CLUSTER, & KEEP(481), DKEEP(8), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_UPDT_TIME = ACC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_LS, & 0, NPARTSCB, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, & .FALSE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS, & CURRENT_BLR, 'V', NCOL1, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (KEEP(201).eq.1) 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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF ENDIF CALL DEALLOC_BLR_PANEL (BLR_LM, NB_BLR_LM, KEEP8, .FALSE.) DEALLOCATE(BLR_LM) IF (NSLAVES_PREC.GT.0) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL,BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF ELSE LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL dgemm('N','N', NCOL-NPIV,NROW1,NPIV,ALPHA,A(UPOS),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) DPOS = POSELT + int(NCOL1 - NROW1,8) 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( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A(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( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, ONE, & A( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO 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. SEND_LR ) THEN LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) 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 ) CALL DMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & SEND_LR, BLR_LS, IPANEL, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 defined(IBC_TEST) WRITE(*,*) MYID,":Send2slave worked" #endif 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 ( NPIV.GT. 0 .AND. SEND_LR ) THEN IF (NSLAVES_PREC.GT.0) THEN IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8, .TRUE.) ENDIF LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( NPIV .NE. 0 ) THEN IF (allocated(UIP21K)) DEALLOCATE( UIP21K ) ENDIF IOLDPS = PTRIST(STEP(INODE)) IF (LASTBL) THEN IF (KEEP(486).NE.0) THEN IF (SEND_LR) 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)), SLAVEF ) 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 (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN CALL DMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, & BEGS_BLR_COL, NB_BLR_COL, NPARTSASS_MASTER, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., 0, KEEP(484)) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 (SEND_LR) 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, .TRUE.) 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 (KEEP(489).EQ.1) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if defined(IBC_TEST) write(6,*) MYID,' :Exiting DMUMPS_PROCESS_SYM_BLOCFACTO for &INODE=', INODE #endif RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.1.2/src/ana_orderings.F0000664000175000017500000150224313164366241016452 0ustar jylexceljylexcelC ========================================================= C This file includes various modifications of an original C LGPL/ CeCILL-C compatible C code implementing the Approximate Minimum Degree ordering C C The main reference for the approach used in routine C MUMPS_ANA_H 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 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND C CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, C BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND C FITNESS FOR A PARTICULAR PURPOSE C ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR C ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL C DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS C OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) C HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, C STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING C IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE C POSSIBILITY OF SUCH DAMAGE. C C All other routines are modifications of this original routine C done by MUMPS developers over the years (1996-2012). 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 SUBROUTINE MUMPS_ANA_H(N, IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W, PARENT) C 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 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: (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----------------------------------------------------------------------- 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 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: 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 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 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 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 + 1 ELEN (I) = -NEL PE (I) = 0 W (I) = 0 ENDIF 20 CONTINUE C ===================================================================== C WHILE (selecting pivots) DO 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 + 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 = 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 + LEN (ME) 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 IPE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_ANA_H C----------------------------------------------------------------------- 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 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 + 1 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 1 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 C write(6,*) ' end of halo: N, NREAL=',N,NREAL, C & ' degree =',(degree(i),i=1,N) C order/flag nodes in V1 C write(6,*) ' end of halo: N, NREAL, NEL=',N,NREAL,NEL C check |V0| + |V1| = N IF (NEL.NE.N) THEN write(*,*) ' Error 2 in MUMPS_HAMD NEL, N=', NEL,N NCMPA = -N - 1 CALL MUMPS_ABORT() 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(N, 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 INTEGER, INTENT(IN) :: N, NBBUCK 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), 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 OUTPUT) 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 OUTPUT) 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 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 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 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 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 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 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 C DEGREE (I) = LEN (I) ENDIF ENDDO ELSE DO I=1,N NV(I) = 1 IF (LEN(I).LT.0) THEN C write(6,*) I, ' was flagged ' DEGREE (I) = N2 NBFLAG = NBFLAG +1 C begin HALO V3 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 DEGREE (I) = LEN (I) ENDIF ENDDO TOTEL = N - NBFLAG ENDIF 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 C version 1 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 C write (*,*) ' Error 1 in HALO_AMD ' C write(6,*) ' NEL, DEG=', NEL,DEG C stop C return to calling program with error return 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) 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 C write(6,*) ' Selected pivot has degree, WF= ', C & me, degree(me), wf(me) C remove me from the list 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.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 + 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.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) C write(*,*) 'ME father of E',ME,E 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 write(*,*) 'ME',ME,'DEG',DEGME,'LP =',IW(PME1:PME2) 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 ------------------------------------------------- C write(*,*) 'merge I,J',I,J 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 ------------------------------------------------------- C-------------------------- 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 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.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) 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.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, 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) = N-NREAL PE(ME) = 0_8 IF (NEL.NE.N) THEN NCMPA = -N - 1 GOTO 500 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 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 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 end COMPRESS 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, IVersion, THRESH, NDENSE, & N, IWLEN, PE, PFREE, LEN, IW, NV, & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, & PARENT) INTEGER, INTENT(IN) :: TOTEL INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: IVersion, THRESH INTEGER(8), INTENT(IN) :: IWLEN INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C NV meaningful as input to encode compressed graphs INTEGER, INTENT(INOUT) :: NV(N) INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), LAST(TOTEL), & PARENT(N) INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(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 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 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) 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 C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod LOGICAL COMPRESS 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 10 I = 1, N NDENSE(I)= 0 LAST (I) = 0 HEAD (I) = 0 C NV (I) = 1 C DEGREE (I) = LEN (I) W (I) = 1 ELEN (I) = 0 10 CONTINUE HEAD(N:TOTEL) = 0 LAST(N:TOTEL) = 0 IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF(COMPRESS) THEN C TOTEL = 0 DO I=1,N C 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) ENDDO ELSE DO I=1,N NV(I) = 1 DEGREE (I) = LEN (I) ENDDO C TOTEL = N 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+1 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+1 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======================================================================= NLEFT = TOTEL - NEL 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 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 get back to Min degree elimination loop C CALL SECFIN(TIME) 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 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(COMPRESS) THEN 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_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 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 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 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) C write(*,*) 'ME father of E',ME,E 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 write(*,*) 'ME',ME,'DEG',DEGME,'LP =',IW(PME1:PME2) 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. 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 (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, 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 IF (NEL.NE.N) THEN NCMPA = -N - 1 GOTO 500 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 ---------------------------------------------------------------- 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. 500 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, 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, 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) :: NV(N), ELEN(N), LAST(N), PARENT(N) C C Input/output 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(N), 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 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, 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(out): - 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 (out) 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 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 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 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 COLD THRESM = max(int(sqrt(dble(N)))+N/8+1, THRESM) COLD THRESM = max(THRESM,1) COLD ThresMin = max( THRESM / 8, 1) COLD ThresPrev = THRESM COLD ENDIF COLD ThresMinINIT = ThresMin 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(N/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)-N MINDEG = 1 NCMPA = 0 NEL = 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 NV (I) = 1 W (I) = 1 ELEN (I) = 0 DEGREE (I) = LEN (I) 10 CONTINUE 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+1 IF (FDEG.NE.N+1) THEN C DEGREE(I) = DEGREE(I)+N+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+1 DEGREE(I) = N+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 + 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).AND.(THRESM.GT.0)) THRESM = N C C======================================================================= C WHILE (selecting pivots) DO 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 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.N) 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.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 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)-(N+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.(N+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.N+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.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 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) C write(6,*) 'NV(me)=', nv(me) 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.N) 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.N) 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.N) 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.N) 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.N) 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.N) ) 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 = 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 IF (DEGREE(I).LE.N) 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)+N+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)) 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.1.2/src/mumps_static_mapping.F0000664000175000017500000051754313164366241020072 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 contains subroutine MUMPS_DISTRIBUTE(n,slavef,icntl,info, & ne,nfsiz,frere,fils,keep,KEEP8, & procnode,ssarbr,nbsa,peak,istat & ) 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(40),info(40) 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 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 & ) 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 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 MINFLOPS = 5.0D7 MINMEM=5.0D6 CL_RATE =0.8D0 DV_RATE=0.2D0 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.(dble(cv_keep(102))/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)=(cv_nodetype(i)-1)*cv_slavef+cv_procnode(i) 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 & ) implicit none integer, intent(in)::n,slavef integer, intent(in), TARGET:: frere(n),fils(n),nfsiz(n),ne(n), & keep(500),icntl(40),info(40), & procnode(n),ssarbr(n) INTEGER(8), intent(in), TARGET:: KEEP8(150) integer,intent(out)::istat 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) 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(40).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,splitting_allowed integer,parameter::map_strat=cv_equilib_flops character (len=48):: err_rep,subname logical use_geist_ng_replace, skiparrangeL0 INTEGER MINSIZE_L0 istat=-1 subname='LAYERL0' accepted=.FALSE. splitting_allowed=.TRUE. splitting_allowed=.FALSE. IF (cv_keep(72).EQ.2) THEN MINSIZE_L0 = 6*cv_slavef ELSE MINSIZE_L0 = 3*cv_slavef ENDIF 55 continue skiparrangeL0 = .false. do while(.not.accepted) IF ( ( (layerL0_endforarrangeL0.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_slavef.GT.16) & skiparrangeL0 = .NOT.skiparrangeL0 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 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) if( (nmb_sons_inode.ge.nmb_procs_inode).AND. & (nmb_procs_inode.LT.4) ) then procs4son = cv_prop_map(inode)%ind_proc 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 call MUMPS_MOD_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(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) npiv=npiv+1 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)) 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(40),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 if(nextpos.le.0) then exit else npiv=npiv+1 nextpos=cv_fils(nextpos) end if 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(150) 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,*) & ' 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) 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(150) 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 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) do i=1,npiv_son-1 f1 = fils(f1) enddo 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)) do i=1,npiv_father-1 in_father=fils(in_father) enddo 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 MUMPS_5.1.2/src/cfac_scalings_simScaleAbs.F0000664000175000017500000013710613164366266020674 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 Check done outside C IF(ISTATUS + NUMPROCS * MPI_STATUS_SIZE - 1>INTSZ) THEN C write(6,*) "Bora: ", ISTATUS + C & NUMPROCS * MPI_STATUS_SIZE - 1,INTSZ C write(6,*) "Bora : TODO. scimscaent_33 REPORT ERROR" C CALL flush(6) C ENDIF 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 C Check done outside C IF( OSRCPTR + OCSNDRCVVOL - 1 > RESZ) THEN C write(6,*) "Bora: NOTE: ", C & OSRCPTR + OCSNDRCVVOL - 1 , RESZ C write(6,*) "Bora: TODO. scimscaent_3 REPORT ERROR" C CALL flush(6) C 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),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 C write(6,*) 'Bora :', RESZ, N, IRSNDRCVVOL, ORSNDRCVVOL C CALL flush(6) 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(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.1.2/src/sana_aux.F0000664000175000017500000034464613164366262015453 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_ANA_F(N, NZ8, IRN, ICN, LIW8, IKEEP, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id) USE SMUMPS_STRUC_DEF USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: IRN(NZ8) INTEGER, INTENT(IN) :: ICNTL(40) INTEGER, INTENT(INOUT) :: ICN(NZ8) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(INOUT) :: INFO(40), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) TYPE (SMUMPS_STRUC) :: id INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE :: 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(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS #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 PIV(N) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL LOGICAL IDENT,SPLITROOT 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 ALLOCATE( IW (LIW8), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIW8,INFO(2)) GOTO 90 ENDIF ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( IPE(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 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 (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN WRITE (MP,99999) N, NZ8, LIW8, INFO(1) J8 = min(10_8,NZ8) IF (LDIAG.EQ.4) J8 = NZ8 IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) 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 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, ICN, IW(1), LIW8, & IPE, 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, SIZE_SCHUR, FRERE, FILS) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif 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, ICN, IW(1), LIW8, & IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265)) DEALLOCATE(IPQ8) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif INFO(8) = symmetry IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .LE. 1 ) 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( N, KEEP(50), NSLAVES, IORD, & symmetry, 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 IF(KEEP(95) .EQ. 2 .AND. IORD .EQ. 0) THEN IF (PROK) WRITE(MP,*) & 'WARNING: SMUMPS_ANA_F AMD not available with ', & ' compressed ordering -> move to QAMD' IORD = 6 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(id%CNTL(4) .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,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) 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, ICN, PIV, & NCMP, IW(1), LIW8, IPE, PTRAR(1,2), IPQ8, & IWL1, FILS, IWFR8, & IERROR, KEEP, KEEP8, ICNTL) 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)=id%COLSCA(J) ENDDO DO J=1, N id%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, ICN, IW(1), LIW8, IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265)) DEALLOCATE(IPQ8) INFO(8) = symmetry 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 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 (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, IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR, 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) 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 IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, N, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, N, 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 CALL SMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS) CALL SMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW(1), & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW(1), & 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 (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(1), IWL1, IKEEP, & IKEEP(1,2), NCMPA, INFO, LP, LPOK) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW(1), IWL1, IKEEP, & IKEEP(1,2), NCMPA, INFO, LP, LPOK, KEEP(10)) 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) THEN CALL SMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS) CALL SMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .GE. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IWL1(1) = -1 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4(NCMP, NBBUCK, LIW8, IPE, & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP, PARENT) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE, & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ, FRERE, PARENT) 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 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 TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_QAMD(TOTEL,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE, IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT) DEALLOCATE(WTEMP) ELSE CALL MUMPS_ANA_H(NCMP, LIW8, IPE, IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL SMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV,IKEEP(1,1),IKEEP(1,2)) 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 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF OPTIONS_METIS(1) = 0 #else OPT_METIS_SIZE = 40 OPT_METIS_SIZE = OPT_METIS_SIZE + 60 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF CALL METIS_SETDEFAULTOPTIONS(OPTIONS_METIS) OPTIONS_METIS(18) = 1 #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(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK, KEEP(10) ) 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(1), NUMFLAG, & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW(1), NUMFLAG, & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10)) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF #else ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW(1),FRERE(1), & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW(1),FRERE(1), & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10) ) 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 DEALLOCATE (OPTIONS_METIS) IF ( COMPRESS_SCHUR ) THEN CALL SMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP(1,1),IKEEP(1,2), & LISTVAR_SCHUR, SIZE_SCHUR, FILS) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL SMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV,IKEEP(1,1),IKEEP(1,2)) 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) & ) THEN DO K=1,N PTRAR(K,1) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (PTRAR(IKEEP(K,1),1).EQ.1) THEN GOTO 40 ELSE PTRAR(IKEEP(K,1),1) = 1 ENDIF ENDDO ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1) THEN IF ((KEEP(106)==1).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, ICN, IW(1), LIW8, & IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265)) DEALLOCATE(IPQ8) INFO(8) = symmetry ENDIF COMPRESS = 0 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. CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, LIW8, IPE, IWFR8, PTRAR(1,2), IW, & IWL1, WTEMP(N+1), & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, & PTRAR(1,3),IKEEP(1,1), LISTVAR_SCHUR, ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ELSE CALL SMUMPS_ANA_J(N, NZ8, IRN, ICN, IKEEP, IW(1), & LIW8, IPE, & 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, IW, LIW8, IWFR8, IKEEP, & IKEEP(1,2), 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, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else IF (allocated(IPE)) DEALLOCATE(IPE) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF CALL SMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, PTRAR, INFO(6), FILS, FRERE, & 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) 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(IKEEP(1,2), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP(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 .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) 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).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 CALL SMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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 CALL SMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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,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 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(IW)) DEALLOCATE(IW) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 9X, I8, I11, I12, I14) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I7, I12, I7, I12, I7)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) END SUBROUTINE SMUMPS_ANA_F 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) 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 #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,INT,NR1 #else INTEGER DADI LOGICAL AMALG_TO_father_OK #endif AMALG_COUNT = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 NODE(I) = 1 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE 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 NODE(IF) = NODE(IF)+1 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 #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 AMALG_TO_father_OK = .TRUE. 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 INT = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT) = -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, MAXFAC, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER NSTEPS,MAXNPIV INTEGER MAXFR, MAXELIM, K50, MAXFAC INTEGER K5,K6,PANEL_SIZE,K253 INTEGER NE(NSTEPS), ND(NSTEPS) INTEGER ITREE, NFR, NELIM INTEGER LKJIB LKJIB = max(K5,K6) MAXFR = 0 MAXFAC = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 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 MAXFAC = max(MAXFAC, (2*NFR - NELIM)*NELIM ) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE MAXFAC = max(MAXFAC, NFR * NELIM) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF 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_ANA_O( N, NZ, MTRANS, PERM, & id, ICNTL, INFO) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(N) INTEGER, INTENT(INOUT) :: MTRANS INTEGER, INTENT(IN) :: ICNTL(40) INTEGER, INTENT(INOUT) :: INFO(40) 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 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)) IF (PROK) WRITE(MPRINT,101) 101 FORMAT(/'****** Preprocessing of original matrix '/) K50 = id%KEEP(50) SCALINGLOC = .FALSE. IF(id%KEEP(52) .EQ. -2) THEN IF(.not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(id%KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF(K50 .NE. 2) THEN IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' ENDIF ENDIF IF(.not.associated(id%A)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF 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 MTRANSLOC = 5 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 => id%IS1(N+1:2*N) STR_KER => id%IS1(2*N+1:3*N) CALL SMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(2) 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 id%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 ) GOTO 410 ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (2*N+1)*id%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 ) GOTO 430 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 = id%IRN(K) J = id%JCN(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 = id%IRN(K) J = id%JCN(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(id%A)) THEN IF(abs(id%A(K)) .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 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 = id%IRN(K) J = id%JCN(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(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF K = 1_8 THEMIN = ZERO DO IF(THEMIN .NE. ZERO) EXIT THEMIN = abs(id%A(K)) K = K+1_8 ENDDO THEMAX = THEMIN DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(id%A(K)) .GT. THEMAX) THEN THEMAX = abs(id%A(K)) ELSE IF(abs(id%A(K)) .LT. THEMIN & .AND. abs(id%A(K)).GT. ZERO) THEN THEMIN = abs(id%A(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(id%A(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 CNTL64(2) = (log(THEMAX/THEMIN))*(real(N)) & - log(THEMIN) + ONE ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => id%IS1(3*N+1:4*N) IF(MTRANSLOC.NE.1) THEN CALL SMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM,IPQ8(1)) ELSE CALL SMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM) 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, 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 = id%JCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 id%JCN(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(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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( id%ROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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 id%KEEP(52) = -2 id%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) id%ROWSCA(J) = exp(S2(RSPOS+J8)) IF(id%ROWSCA(J) .EQ. ZERO) THEN id%ROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN id%COLSCA(J)= exp(S2(CSPOS+J8)) IF(id%COLSCA(J) .EQ. ZERO) THEN id%COLSCA(J) = ONE ENDIF ELSE id%COLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(id%COLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN id%COLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(id%COLSCA)) DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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( id%ROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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 id%KEEP(52) = -2 id%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 id%ROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(id%ROWSCA(J) .EQ. ZERO) THEN id%ROWSCA(J) = ONE ENDIF id%COLSCA(J)= id%ROWSCA(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) id%ROWSCA(I) = ONE / COLNORM id%COLSCA(I) = id%ROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. id%KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. id%KEEP(95) .EQ. 0) THEN MTRANS = 0 id%KEEP(95) = 1 GOTO 390 ELSE IF(id%KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN id%KEEP(95) = 3 ELSE id%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 => id%IS1(2*N+1:3*N) FLAG => id%IS1(3*N+1:4*N) PIV_OUT => id%IS1(4*N+1:5*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, & 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( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 & ) THEN IDENT = .TRUE. id%KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF id%KEEP(93) = INFO_SYM_MWM(4) id%KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN id%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 SUBROUTINE SMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL ) IMPLICIT NONE INTEGER COMM, MYID, KEEP(500), INFO(40), ICNTL(40), INFOG(40) 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), 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) Storage of factors (REAL, estimated) =',I16/ & ' -- (4) Storage of factors (INT , 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/ & 'Percentage of memory relaxation (effective) =',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, 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 ) 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 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)), & 1_8) IF (KEEP(53).NE.0) THEN MAX_CUT = NFRONT K79 = 121_8*121_8 ELSE K79 = min(2000_8*2000_8,K79) 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 ) 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 ) 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 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_SON, NPIV_FATH 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 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 DO WHILE( IN > 0 ) IN = FILS( IN ) NPIV = NPIV + 1 END DO 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)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375)) 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 NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 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 IN_SON = INODE DO I = 1, NPIV_SON - 1 IN_SON = FILS( IN_SON ) END DO 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 ) 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 ) 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) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) 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 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) 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 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE 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 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 ((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 ELSE symmetry = 100 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 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_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(40) 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).GE.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, 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(INOUT) :: INFO(40) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN 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) IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO 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 DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE SMUMPS_SORT_PERM SUBROUTINE SMUMPS_ANA_N_PAR( id, PTRAR ) USE SMUMPS_STRUC_DEF IMPLICIT NONE include 'mpif.h' TYPE(SMUMPS_STRUC), INTENT(IN), TARGET :: id INTEGER(8), INTENT(OUT), TARGET :: PTRAR(id%N,2) INTEGER :: IERR 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(1:id%N,2) allocate(IWORK2(id%N)) IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => PTRAR(1:id%N,1) IWORK2 => PTRAR(1:id%N,2) 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,1), id%N, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), id%N, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR, 2*id%N, MPI_INTEGER8, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE SMUMPS_ANA_N_PAR SUBROUTINE SMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(40),INFOG(40),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) REAL PEAK CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & ) 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.1.2/src/zsol_bwd_aux.F0000664000175000017500000011163513164366265016345 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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(40), 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 MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8) RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) #endif 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 DOUBLE PRECISION :: TIME_TMP 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 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE ZMUMPS_OOC 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(40), 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 MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8) RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) #endif INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED 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(8) :: P_UPDATE, P_SOL_MAS 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_TMP, IPOSINRHSCOMP_PANEL DOUBLE PRECISION :: TIME_TMP INTEGER JBDEB, JBFIN, NRHS_B, allocok 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 MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE, ztrsv, ztrsm, zgemv, zgemm 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 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. FEUILLE) 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 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 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP) = W(POSWCB+1+JJ) #else RHSCOMP(IPOSINRHSCOMP,K) = W(POSWCB+1+JJ) #endif ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( KEEP(237).GT. 0 ) 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)), & SLAVEF) .eq. MYID ) THEN IF ( KEEP(237).GT. 0 ) 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 IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF (KEEP(201).GT.0) 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(IW( IPOS + 3 )) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 in 41S : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - LONG*NRHS_B .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 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + NPIV * NRHS_B PLEFTW = P_SOL_MAS + NROW_L * NRHS_B 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).EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE #endif CALL zgemm( 'T', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE #endif CALL zgemm( 'N', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF IF (KEEP(201).GT.0) 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 - NROW_L * NRHS_B 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 ) 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = W2(I) #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) #endif I = I+1 ENDDO ELSE DO JJ = J1,J2 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) + W2(I) #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) #endif 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) 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) 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 )) IF (KEEP(350).EQ.0) THEN DO K=JBDEB, JBFIN DO JJ = J1, J2 W(IFR8+JJ-J1+(K-JBDEB)*LIELL) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif END DO END DO ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*) "Internal error ZMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR8 = IFR8 + 1 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(K,IPOSINRHSCOMP_TMP) #else W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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 ELSE WRITE(*,*) "Internal error ZMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF IF ( KEEP(201).EQ.1 .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 (KEEP(350).EQ.0) THEN CALL zgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( PTWCB_PANEL + int(NBJ,8) ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ELSE IF (NCB_PANEL - NCB.NE. 0) THEN CALL zgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), & 1, ONE, & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF IF (NCB .NE. 0) THEN CALL zgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + NPIV ), & 1, ONE, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF ENDIF ENDIF IF (KEEP(350).eq.0) THEN CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (KEEP(350).eq.0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(PTWCB_PANEL+int(NBJ,8)),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in ZMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else 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 ENDIF ENDIF IF (KEEP(350).eq.0) THEN CALL ztrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in ZMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL ztrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF 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 IF (KEEP(350).EQ.0) THEN CALL zgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & W(PTRACB(STEP(INODE))), 1 ) ELSE CALL zgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE IF (KEEP(350).EQ.0) THEN CALL zgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, W(PTRACB(STEP(INODE))),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in ZMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL zgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF END IF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL ztrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & W(PTRACB(STEP(INODE))),1) ELSE CALL ztrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL ztrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & W(PTRACB(STEP(INODE))),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in ZMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL ztrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif 1234 CONTINUE IF (KEEP(201).GT.0) 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO I = 1, NPIV DO K=JBDEB,JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) #else RHSCOMP( IPOSINRHSCOMP_TMP , K ) = & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) #endif ENDDO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*)"Internal error in ZMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF IN = INODE 200 IN = FILS(IN) IF (IN .GT. 0) GOTO 200 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, 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 ( KEEP(237).GT.0 ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( KEEP(237).GT.0 ) 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)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & SLAVEF ) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 IF (NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, FEUILLE, 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=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 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 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE DEALLOCATE(DEJA_SEND) RETURN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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.1.2/src/zfac_process_message.F0000664000175000017500000010313413164366265020025 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 40 ) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, 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(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,SLAVEF, & 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(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, NBPROCFILS, & N, IW, LIW, A, LA, & 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, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, COMP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF) 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)), & SLAVEF ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF)) 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)),SLAVEF) & ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' 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(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/ctype3_root.F0000664000175000017500000012672513164366264016124 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_ASS_ROOT( NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) IMPLICIT NONE 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 IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON DO J = 1, NCOL_SON-NSUPCOL VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) = & VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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))) 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, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) NBPROCFILS( STEP(IROOT) ) = -1 #if ! defined(NO_XXNBPR) KEEP(121) = -1 #endif IF (IFLAG.LT.0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT)) - 1 #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) - 1 #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN #endif 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(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 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, A( PTRR( STEP(ISON)) + 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, A( PTRR( STEP(ISON)) + 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) 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_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, A( PTRR(STEP(ISON)) + 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, root%RG2L_COL, & 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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 ) IMPLICIT NONE INCLUDE 'cmumps_root.h' 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 ) 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 & ) IMPLICIT NONE INCLUDE 'cmumps_root.h' 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 ) IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE ( CMUMPS_ROOT_STRUC ):: root INTEGER N, IROOT, INFO(40), KEEP(500) INTEGER FILS( N ) INTEGER INODE, I, allocok IF ( associated( root%RG2L_ROW ) ) DEALLOCATE( root%RG2L_ROW ) IF ( associated( root%RG2L_COL ) ) DEALLOCATE( root%RG2L_COL ) 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 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, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IMPLICIT NONE INCLUDE 'cmumps_root.h' 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 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 ) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N ) 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 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 RETURN ENDIF 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, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, 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 RETURN END SUBROUTINE CMUMPS_ROOT_ALLOC_STATIC SUBROUTINE CMUMPS_ASM_RHS_ROOT & ( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) IMPLICIT NONE INCLUDE 'cmumps_root.h' 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 MUMPS_5.1.2/src/estim_flops.F0000664000175000017500000001044713164366241016162 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE MUMPS_ESTIM_FLOPS( INODE, N, PROCNODE_STEPS, & SLAVEF, & ND, FILS, FRERE_STEPS, STEP, PIMASTER, & KEEP28, KEEP50, KEEP253, & FLOP1, & IW, LIW, XSIZE ) IMPLICIT NONE INTEGER INODE, N, KEEP50, LIW, SLAVEF, 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)), & SLAVEF) ) 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)),SLAVEF) 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 MUMPS_5.1.2/src/cfac_scalings_simScale_util.F0000664000175000017500000011743413164366266021305 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zsol_bwd.F0000664000175000017500000012216313164366265015466 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NA, LNA, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, 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 & , TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE ZMUMPS_OOC USE ZMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER(8), intent(in) :: LWC INTEGER N,LIW,LIWW,LPOOL,LNA INTEGER SLAVEF,MYLEAF,COMM,MYID INTEGER LPANEL_POS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NA(LNA),NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(40), INFO(40) 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) #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8) RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) #endif INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) 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 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INTEGER POSIWCB,K INTEGER(8) :: APOS, IST INTEGER(8) :: IFR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB,NBFINF INTEGER NBLEAF,INODE,NBROOT,NROOT,NBFILS INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER III,IIPOOL,MYLEAFE INTEGER NSLAVES INTEGER JBDEB, JBFIN, NRHS_B COMPLEX(kind=8) ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0D0,0.0D0), & ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) LOGICAL BLOQ,DEBUT INTEGER PROCDEST, DEST INTEGER POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL, & IPOSINRHSCOMP_TMP INTEGER DUMMY(1) INTEGER(8) :: POSWCB, PLEFTW, PTWCB INTEGER Offset, EffectiveSize, ISLAVE, FirstIndex LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INCLUDE 'mumps_headers.h' LOGICAL BLOCK_SEQUENCE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL Exploit_Sparsity, AM1 DOUBLE PRECISION :: TIME_TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok 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 LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER MUMPS_TYPENODE EXTERNAL zgemv, ztrsv, ztrsm, zgemm, & MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR 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 NROOT = 0 NBLEAF = NA(1) NBROOT = NA(2) DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) .EQ. MYID) THEN NROOT = NROOT + 1 IPOOL(NROOT) = INODE ENDIF END DO III = 1 IIPOOL = NROOT + 1 BLOCK_SEQUENCE = .FALSE. Exploit_Sparsity = .FALSE. AM1 = .FALSE. IF (KEEP(235).NE.0) Exploit_Sparsity = .TRUE. IF (KEEP(237).NE.0) AM1 = .TRUE. NO_CHILDREN = .FALSE. IF (Exploit_Sparsity .OR. AM1) MYLEAF = -1 IF (MYLEAF .EQ. -1) THEN MYLEAF = 0 DO I=1, NBLEAF INODE=NA(I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) .EQ. MYID) THEN MYLEAF = MYLEAF + 1 ENDIF ENDDO ENDIF MYLEAFE=MYLEAF NBFINF = SLAVEF IF (MYLEAFE .EQ. 0) THEN CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) THEN GOTO 340 ENDIF ENDIF 50 CONTINUE 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 GO TO 60 ENDIF END IF IF ( NBFINF .eq. 0 ) GOTO 340 GOTO 50 IF (MYID.EQ.0) write(6,*) "BWD: process INODE=", INODE 60 CONTINUE 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO JJ = J1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP_TMP) = RHS_ROOT(IFR+NPIV*(K-1)) #else RHSCOMP(IPOSINRHSCOMP_TMP,K) = RHS_ROOT(IFR+NPIV*(K-1)) #endif END DO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE CALL ZMUMPS_SOL_CPY_FS2RHSCOMP(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) ENDIF IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 ENDIF GOTO 50 ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( AM1 ) 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 DEBUT = .TRUE. DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( AM1 ) 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)),SLAVEF) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & SLAVEF) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) GOTO 330 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF ( IERR .NE. 0 ) CALL MUMPS_ABORT() ENDIF IF = FRERE(STEP(IF)) ENDDO IF (AM1 .AND.NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 ENDIF 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 GOTO 50 END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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)) GOTO 330 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 330 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2 - KEEP(253) J = IW(JJ) IFR = IFR + 1_8 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN W(IFR+int(K-JBDEB,8)*int(NCB,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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) ELSE WRITE(*,*) "Internal error ZMUMPS_SOL_S" CALL MUMPS_ABORT() END IF 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 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) GOTO 50 ENDIF 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) 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 330 ENDIF ENDIF APOS = PTRFAC(IW(IPOS)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1) 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)) GOTO 330 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) ) GOTO 330 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 330 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(350).eq.0) THEN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = ZERO ENDDO ELSE DO JJ = J1, J2 #if defined(RHSCOMP_BYROWS) W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif ENDDO ENDIF ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = ZERO ENDDO ENDIF ELSE WRITE(*,*) "Internal error ZMUMPS_SOL_BWD" CALL MUMPS_ABORT() 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1_8 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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) ELSE WRITE(*,*) "Internal error ZMUMPS_SOL_S" CALL MUMPS_ABORT() ENDIF 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) 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 (KEEP(350).EQ.0) THEN CALL zgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( PTWCB_PANEL+int(NBJ,8) ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ELSE IF (NCB_PANEL - NCB.NE. 0) THEN CALL zgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), & 1, ONE, & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif 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, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF ENDIF ENDIF IF (MTYPE.NE.1) THEN IF (KEEP(350).eq.0) THEN CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ELSE IF (KEEP(350).eq.0) THEN CALL ztrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL ztrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (KEEP(350).eq.0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(PTWCB_PANEL+int(NBJ,8)),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in ZMUMPS_SOL_S" CALL MUMPS_ABORT() #else 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 ENDIF ENDIF IF (MTYPE.NE.1) THEN IF (KEEP(350).eq.0) THEN CALL ztrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in ZMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL ztrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF ELSE IF (KEEP(350).eq.0) THEN CALL ztrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in ZMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL ztrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ENDIF IF (KEEP(201).EQ.0.OR.KEEP(201).EQ.2)THEN 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 IF (KEEP(350).EQ.0) THEN CALL zgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & W(PTWCB), 1 ) ELSE CALL zgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL zgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & W(PTWCB), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in ZMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL zgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #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 IF (KEEP(350).EQ.0) THEN CALL zgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB+int(NPIV,8) ), & 1, ONE, & W(PTWCB), 1 ) ELSE CALL zgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL zgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, W(PTWCB),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in ZMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL zgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB),LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL ztrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL ztrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL ztrsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), & LIELL, W(PTWCB), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in ZMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL ztrsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), & LIELL, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE LDAJ=NPIV ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL ztrsv('U','N','U', NPIV, A(APOS), LDAJ, & W(PTWCB), 1) ELSE CALL ztrsv('U','N','U', NPIV, A(APOS), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL ztrsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), & LDAJ,W(PTWCB),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in ZMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL ztrsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), & LDAJ, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif END IF 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO 150 I = 1, NPIV DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP_TMP) = W(PTWCB+I-1+(K-JBDEB)*LIELL) #else RHSCOMP(IPOSINRHSCOMP_TMP, K) = W(PTWCB+I-1+(K-JBDEB)*LIELL) #endif ENDDO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 150 CONTINUE ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*)"Internal error in ZMUMPS_SOL_S" CALL MUMPS_ABORT() ENDIF 160 CONTINUE IF (KEEP(201).GT.0) 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 330 ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 ENDIF GOTO 50 ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF (AM1) 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 ( AM1 ) 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 (AM1 .AND. NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 ENDIF ENDIF ELSE DEBUT = .TRUE. DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( AM1 ) 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)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),SLAVEF) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 330 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF (AM1 .AND. NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 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 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 GOTO 50 330 CONTINUE CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, & SLAVEF, KEEP) 340 CONTINUE CALL ZMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE ZMUMPS_SOL_S MUMPS_5.1.2/src/dfac_front_LU_type1.F0000664000175000017500000005060413164366264017471 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS & , LRGROUPS & ) 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 !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR, NOFFW, NPVW 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) 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 DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVOT_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 CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok INTEGER :: OMP_NUM INCLUDE 'mumps_headers.h' IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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) 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(BEGS_BLR) 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 (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 IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 PIVOT_OPTION = 4 CNT_NODES = CNT_NODES + 1 CALL INIT_STATS_FRONT(NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL INIT_STATS_FRONT(-NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1FR) ENDIF IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL DMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW, & 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 & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( (KEEP(201).EQ.1).AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. (.NOT. COMPRESS_PANEL) .OR. & (KEEP(485).EQ.0) & ) & ) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) END IF 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, .FALSE., .TRUE., & .FALSE. ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) END IF 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, (PIVOT_OPTION.LT.2), .TRUE., & .FALSE. ) ENDIF ELSE CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 1, 0) NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF CALL SYSTEM_CLOCK(T1) IF (IEND_BLR.LT.NFRONT .AND. PIVOT_OPTION.EQ.4) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & -66666, & A, LA, POSELT, .FALSE., .FALSE., & .FALSE. ) ENDIF CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_TRSM_TIME = LOC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR)) ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) IF (IFLAG.LT.0) GOTO 400 CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H', 1) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V', 1) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) END IF IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & . FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF (KEEP(201).EQ.1) 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 IF (COMPRESS_CB) THEN CALL DMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, NPARTSCB+NPARTSASS, & BEGS_BLR, NPARTSCB+NPARTSASS, NPARTSASS, & DKEEP(8), NASS, NFRONT-NASS, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, STEP_STATS(INODE), 1, & .FALSE., 0, KEEP(484)) ENDIF CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NFRONT-NASS, & KEEP(50), INODE, NASS-NPIV) CALL STATS_COMPUTE_FLOP_FRONT_TYPE1(NFRONT, NASS, NPIV, & KEEP(50), INODE) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) DEALLOCATE(WORK) DEALLOCATE(RWORK) DEALLOCATE(TAU) DEALLOCATE(JPVT) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF 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, LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 490 CONTINUE write(*,*) 'Allocation problem in BLR routine & DMUMPS_FAC_FRONT_LU_TYPE1: ', & 'not enough memory? memory requested = ' , IERROR 500 CONTINUE NPVW = NPVW + IW(IOLDPS+1+XSIZE) RETURN END SUBROUTINE DMUMPS_FAC1_LU END MODULE DMUMPS_FAC1_LU_M MUMPS_5.1.2/src/cmumps_f77.F0000664000175000017500000003267613164366264015642 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, 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, & 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, & IRHS_SPARSE, IRHS_SPARSEhere, & IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, & NZ_RHS, LSOL_loc & , & SCHUR_MLOC, & SCHUR_NLOC, & SCHUR_LLD, & MBLOCK, & NBLOCK, & NPROW, & NPCOL, & & OOC_TMPDIR, & OOC_PREFIX, & WRITE_PROBLEM, & TMPDIRLEN, & PREFIXLEN, & WRITE_PROBLEMLEN & & ) 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 JOB, SYM, PAR, COMM_F77, N, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(40), INFO(40), INFOG(40), 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(*), ISOL_loc(*) 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(*) 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 IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, PERM_INhere, WK_USERhere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, IRHS_PTRhere, IRHS_SPARSEhere, ISOL_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 A_ELT_SIZE, I, Np, IERR INTEGER(8) :: 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 mumps_par_array(INSTANCE_NUMBER)%PTR%KEEP(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%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:40)=ICNTL(1:40) 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%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_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 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:A_ELT_SIZE) END IF 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:NRHS*LRHS) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:NRHS*LREDRHS) 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:LSOL_loc*NRHS) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_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 CALL CMUMPS( mumps_par ) INFO(1:40)=mumps_par%INFO(1:40) INFOG(1:40)=mumps_par%INFOG(1:40) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:40) = mumps_par%ICNTL(1:40) 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) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N 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 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.1.2/src/sfac_mem_stack_aux.F0000664000175000017500000001530613164366262017454 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, COMPRESSCB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: COMPRESSCB 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. COMPRESSCB ) 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. COMPRESSCB) 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, COMPRESSCB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: COMPRESSCB 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 > 300) DO I = 1, NBROW_STACK IF (COMPRESSCB) 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. COMPRESSCB) 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.1.2/src/zmumps_driver.F0000664000175000017500000025532713164366266016563 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 -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, 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). These 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. * * 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. 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. * Other values for the parameter JOB can invoke combinations of these * three basic operations. 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_8) THEN id%KEEP8(29) = id%NNZ_loc ELSE id%KEEP8(29) = int(id%NZ_loc, 8) ENDIF ENDIF C C IF (JOB.EQ.-2.OR.JOB.EQ.1.OR.JOB.EQ.2.OR.JOB.EQ.3.OR. & JOB.EQ.4.OR.JOB.EQ.5.OR.JOB.EQ.6 & ) THEN C Correct value of JOB C ICNTL should have been initialized and can be used LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%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 (id%KEEP(500).EQ.1) THEN FROM_C_INTERFACE_STRING=" from C interface" ELSE FROM_C_INTERFACE_STRING=" " ENDIF IF (PROKG) THEN C Print basic information on MUMPS call IF (JOB .EQ. -2 & ) THEN C N, NELT, NNZ not meaningful WRITE(MPG,'(/A,A,A,A,I4,I12)') & 'Entering ZMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB =', JOB ELSE IF (id%ICNTL(5) .NE. 1) THEN C Assembled format IF (id%ICNTL(18) .EQ. 0 & ) THEN WRITE(MPG,'(/A,A,A,A,I4,I12,I15)') & 'Entering ZMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB, N, NNZ =', JOB,id%N,id%KEEP8(28) ELSE WRITE(MPG,'(/A,A,A,A,I4,I12)') & 'Entering ZMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB, N =', JOB,id%N ENDIF ELSE C Elemental format WRITE(MPG,'(/A,A,A,A,I4,I12,I15)') & 'Entering ZMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' driver with JOB, N, NELT =', JOB,id%N,id%NELT ENDIF C MPI and OpenMP information !$ IF (.TRUE.) THEN !$ WRITE(MPG, '(A,I6,A,I6)') ' executing #MPI = ', !$ & id%NPROCS, ' and #OMP = ', NOMP !$ IF ( NOMPMIN .NE. NOMPMAX ) THEN !$ WRITE(MPG, '(A,I4,A,I4,A)') !$ & ' WARNING detected: different number of threads (max ', !$ & NOMPMAX, ', min ', NOMPMIN, ')' !$ END IF !$ ELSE WRITE(MPG, '(A,I6,A)') ' executing #MPI = ', & id%NPROCS, ', without OMP' !$ ENDIF IF (JOB.GE.1 .AND. JOB.LE.6) THEN WRITE(MPG, '(A)') ENDIF ENDIF END IF C C---------------------------------------------------------------- C C JOB = -1 : START INITIALIZATION PHASE C (NEW INSTANCE) C C JOB = -2 : TERMINATE AN INSTANCE C---------------------------------------------------------------- C IF ( JOB .EQ. -1 ) THEN C C ------------------------------------------ C Check that we have called (JOB=-2), ie C that the previous JOB is not 1 2 or 3, C before calling the initialization routine. C -------------------------------------------- id%INFO(1)=0 id%INFO(2)=0 OLDJOB = id%KEEP( 40 ) + 456789 IF ( OLDJOB .EQ. 1 .OR. & OLDJOB .EQ. 2 .OR. & OLDJOB .EQ. 3 ) THEN IF ( id%N > 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---------------------------------------------------------------- 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----------------------------------------------------------------------- C TIMINGS IF (id%MYID .eq. MASTER) THEN id%DKEEP(70)=0.0D0 CALL MUMPS_SECDEB(TIMETOTAL) END IF OLDJOB = id%KEEP( 40 ) + 456789 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 IS1 :allocated on the master now, will be allocated on C the slaves later 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 IF (associated(id%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) ENDIF C ------------------------------------------- C Allocate array IS1 for analysis of size: C - assembled entry: 10 * N or 11 * N C depending on max-trans C - element entry: 7 * N + 3 * NELT + 3 C max-trans not allowed C ------------------------------------------- IF ( id%ICNTL(5) .NE. 1 ) THEN ! assembled matrix IF ( id%KEEP(50) .NE. 1 & .AND. ( & (id%ICNTL(6) .NE. 0 .AND. id%ICNTL(7) .NE.1) & .OR. & id%ICNTL(12) .NE. 1) ) THEN id%MAXIS1 = 7 * id%N ELSE id%MAXIS1 = 6 * id%N END IF ELSE id%MAXIS1 = 6 * id%N ENDIF ALLOCATE( id%IS1(id%MAXIS1), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%MAXIS1 IF ( LPOK ) WRITE(LP,'(A)') & ' Problem in allocating work array for analysis' GO TO 100 END IF C C ---------------------- C Allocate PROCNODE(1:N) C ---------------------- IF ( associated( id%PROCNODE ) ) & DEALLOCATE( id%PROCNODE ) ALLOCATE( id%PROCNODE(id%N), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%N IF ( LPOK ) WRITE(LP,'(A)') & 'Problem in allocating work array PROCNODE' GOTO 100 END IF id%PROCNODE(1:id%N) = 0 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. 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 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 ------------------------------------------- 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 CALL ZMUMPS_ANA_DRIVER( id ) C Save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ELSE id%INFOG(33)=id%ICNTL(8) ENDIF 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 (id%MYID .eq. MASTER.AND.id%KEEP(492).EQ.0) THEN C No front to be selected for LR id%KEEP(486) = 0 IF (PROKG) & write(MPG,'(A)') " Low rank reset off since no front selected " 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), & id%SIZE_SCHUR*id%SIZE_SCHUR) 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( id%KEEP(52) .EQ. -2 .AND. id%ICNTL(8) .NE. -2 .AND. & id%ICNTL(8).NE. 77 ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** scaling already computed during analysis' WRITE(MPG,'(A)') & ' ** keeping the scaling from the analysis' ENDIF ENDIF IF (id%KEEP(52) .NE. -2) THEN 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 IF ( id%KEEP( 19 ) .ne. 0 .and. id%KEEP( 52 ).ne. 0 ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') ' ** (incompatibility with null space)' END IF id%KEEP(52) = 0 END IF 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 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) id%INFO(1)=-13 ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 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) id%INFO(1)=-13 IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 IF ( id%INFO(1) .eq. -13 ) THEN 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) 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), & id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) 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)) 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 (associated(id%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) ENDIF IF (associated(id%PROCNODE)) THEN DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) ENDIF #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) = TIMEG ENDIF 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 = 40 INTEGER :: INFO(40) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(40) 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 .and. INFO(2) .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 SUBROUTINE ZMUMPS_PRINT_ICNTL(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 INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL 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) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 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,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) 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) WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) CASE(5); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(6); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 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) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 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 =',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 ( 0= off, else=on) =',I10/ & 'ICNTL(20) Dense (0) or sparse (1) 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) Dense (0) or sparse (1) 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 & (size(idRHS)<(idNRHS*idLRHS-idLRHS+idN)) & 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.1.2/src/smumps_load.F0000664000175000017500000065451413164366263016176 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) INTEGER, SAVE, PRIVATE :: NB_LEVEL2 LOGICAL, PRIVATE :: AMI_CHOSEN,IS_DISPLAYED #endif #endif #if ! defined(OLD_LOAD_MECHANISM) DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM #else DOUBLE PRECISION, SAVE, PRIVATE :: LAST_LOAD_SENT, & DM_LAST_MEM_SENT #endif 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 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, K66, & K375, MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER, INTENT(IN) :: K64, K66, K375 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(K66), 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 (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(40), & 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .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(40), & 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .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(40), & 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(40) 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 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 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 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)) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE TYPE(SMUMPS_STRUC), TARGET :: id INTEGER(8), intent(in) :: MEMORY_MD_ARG INTEGER(8), intent(in) :: MAXS INTEGER K34_LOC,K35_LOC INTEGER allocok, IERR, i, BUF_LOAD_SIZE DOUBLE PRECISION :: MAX_SBTR DOUBLE PRECISION ZERO DOUBLE PRECISION MEMORY_SENT PARAMETER( ZERO=0.0d0 ) DOUBLE PRECISION SIZE_REAL(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 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 ) 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 #if ! defined(OLD_LOAD_MECHANISM) 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 #endif CHECK_MEM=0_8 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) NB_LEVEL2=0 AMI_CHOSEN=.FALSE. IS_DISPLAYED=.FALSE. #endif #endif 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) 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) 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) SBTR_PEAK_ARRAY=dble(0) IF (allocated(SBTR_CUR_ARRAY)) DEALLOCATE(SBTR_CUR_ARRAY) ALLOCATE(SBTR_CUR_ARRAY(id%NBSA_LOCAL),stat=allocok) 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_REAL(1),SIZE_REAL(2),K35_LOC) K35 = K35_LOC BUF_LOAD_SIZE = K34_LOC * 2 * ( NPROCS - 1 ) + & NPROCS * ( K35_LOC + K34_LOC ) IF (BDC_MEM) THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35_LOC END IF IF (BDC_SBTR)THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35_LOC 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 defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MYID ) = COST_SUBTREE LAST_LOAD_SENT = ZERO #endif IF ( BDC_MEM ) THEN DO i = 0, NPROCS - 1 DM_MEM( i )=ZERO END DO #if defined(OLD_LOAD_MECHANISM) DM_LAST_MEM_SENT=ZERO #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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 TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL SMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE DOUBLE PRECISION INC_LOAD INTEGER KEEP(500) INTEGER(8) KEEP8(150) LOGICAL PROCESS_BANDE 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 ! defined(OLD_LOAD_MECHANISM) IF ( PROCESS_BANDE ) THEN RETURN ENDIF #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 #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = DELTA_LOAD + & (INC_LOAD-REMOVE_NODE_COST) GOTO 888 #else GOTO 888 #endif ELSE #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = DELTA_LOAD - & (REMOVE_NODE_COST-INC_LOAD) GOTO 888 #else GOTO 888 #endif ENDIF ENDIF GOTO 333 ENDIF #if ! defined(OLD_LOAD_MECHANISM) 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 #else 888 CONTINUE IF ( abs( LOAD_FLOPS ( MYID ) - & LAST_LOAD_SENT ).GT.MIN_DIFF)THEN IERR = 0 SEND_LOAD = LOAD_FLOPS( MYID ) IF ( BDC_MEM ) THEN SEND_MEM = DM_MEM(MYID) ELSE SEND_MEM = ZERO END IF #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_UPDATE",IERR CALL MUMPS_ABORT() ENDIF IF ( IERR .EQ. 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = ZERO IF (BDC_MEM) DELTA_MEM = ZERO #else LAST_LOAD_SENT = LOAD_FLOPS( MYID ) IF ( BDC_MEM ) DM_LAST_MEM_SENT = DM_MEM( MYID ) #endif END IF 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 #if defined(OLD_LOAD_MECHANISM) DOUBLE PRECISION TMP_MEM #endif IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN PROCESS_BANDE=PROCESS_BANDE_ARG INC_MEM = INC_MEM_ARG #if ! defined(OLD_LOAD_MECHANISM) 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 #endif #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) IF(PROCESS_BANDE)THEN PROCESS_BANDE=.FALSE. NB_LEVEL2=NB_LEVEL2-1 IF(NB_LEVEL2.LT.0)THEN WRITE(*,*)MYID,': problem with NB_LEVEL2' ELSEIF(NB_LEVEL2.EQ.0)THEN IF(IS_DISPLAYED)THEN IS_DISPLAYED=.FALSE. ENDIF AMI_CHOSEN=.FALSE. ENDIF ENDIF IF((KEEP(73).EQ.0).AND.(NB_LEVEL2.NE.0) & .AND.(.NOT.IS_DISPLAYED))THEN IS_DISPLAYED=.TRUE. ENDIF #endif #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 ! defined(OLD_LOAD_MECHANISM) IF (PROCESS_BANDE) THEN RETURN ENDIF #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 defined(OLD_LOAD_MECHANISM) IF(KEEP_LOAD(201).EQ.0)THEN DM_MEM( MYID ) = dble(CHECK_MEM) - DM_SUMLU ELSE DM_MEM( MYID ) = dble(CHECK_MEM) ENDIF TMP_MEM = DM_MEM(MYID) #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 ! defined(OLD_LOAD_MECHANISM) 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 #else IF(BDC_M2_MEM.AND.REMOVE_NODE_FLAG_MEM)THEN IF(INC_MEM.NE.REMOVE_NODE_COST_MEM)THEN IF(INC_MEM.EQ.REMOVE_NODE_COST_MEM)THEN GOTO 333 ELSEIF(INC_MEM.LT.REMOVE_NODE_COST_MEM)THEN GOTO 333 ENDIF ENDIF ENDIF IF ((KEEP(48).NE.5).OR. & ((KEEP(48).EQ.5).AND. & (abs(TMP_MEM-DM_LAST_MEM_SENT).GE. & 0.2d0*dble(LRLUS))))THEN IF ( abs( TMP_MEM-DM_LAST_MEM_SENT) > & DM_THRES_MEM ) THEN IERR = 0 SEND_MEM = TMP_MEM #endif 111 CONTINUE CALL SMUMPS_BUF_SEND_UPDATE_LOAD( & BDC_SBTR, & BDC_MEM,BDC_MD, COMM_LD, & NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & DELTA_LOAD, #else & LOAD_FLOPS( MYID ), #endif & SEND_MEM,SBTR_TMP, & DM_SUMLU, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_MEM_UPDATE",IERR CALL MUMPS_ABORT() ENDIF IF ( IERR .EQ. 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = ZERO DELTA_MEM = ZERO #else LAST_LOAD_SENT = LOAD_FLOPS ( MYID ) DM_LAST_MEM_SENT = TMP_MEM #endif END IF 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 ) #if ! defined(OLD_LOAD_MECHANISM) DEALLOCATE(FUTURE_NIV2) #endif 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 IERR, MSGTAG, MSGLEN, MSGSOU,COMM INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL FLAG 10 CONTINUE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) 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) 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) 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 ) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE INTEGER MSGSOU, LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INCLUDE 'mpif.h' INTEGER POSITION, IERR, WHAT, NSLAVES, i 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 ) IF ( WHAT == 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) #else #endif CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR ) #if ! defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED #else LOAD_FLOPS( MSGSOU ) = LOAD_RECEIVED #endif IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR ) #if ! defined(OLD_LOAD_MECHANISM) DM_MEM(MSGSOU) = DM_MEM(MSGSOU) + LOAD_RECEIVED #else DM_MEM(MSGSOU) = LOAD_RECEIVED #endif 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 ) 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 ) 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) WRITE(*,*)MYID,':Receiving M2A from',MSGSOU i=1 DO WHILE ((i.LE.NSLAVES).AND.(LIST_SLAVES(i).NE.MYID)) i=i+1 ENDDO IF(i.LT.(NSLAVES+1))THEN NB_LEVEL2=NB_LEVEL2+1 WRITE(*,*)MYID,':NB_LEVEL2=',NB_LEVEL2 AMI_CHOSEN=.TRUE. IF(KEEP_LOAD(73).EQ.1)THEN IF(.NOT.IS_DISPLAYED)THEN WRITE(*,*)MYID,': Begin of Incoherent state (2) at time=', & MPI_WTIME()-TIME_REF IS_DISPLAYED=.TRUE. ENDIF ENDIF ENDIF IF(KEEP_LOAD(73).EQ.1) GOTO 344 #endif #endif DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif LOAD_FLOPS(LIST_SLAVES(i)) = & LOAD_FLOPS(LIST_SLAVES(i)) + & LOAD_INCR(i) #if defined(OLD_LOAD_MECHANISM) END IF #endif END DO IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif 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))) #if defined(OLD_LOAD_MECHANISM) END IF #endif 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) 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 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) 344 CONTINUE #endif #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 ) 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 ) SBTR_MEM(MSGSOU)=SBTR_MEM(MSGSOU)+LOAD_RECEIVED #if ! defined(OLD_LOAD_MECHANISM) 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 ) MD_MEM(MSGSOU)=999999999_8 TAB_MAXS(MSGSOU)=TAB_MAXS(MSGSOU)+int(SURF,8) ENDIF #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 ) 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR ) IF( & MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE_RECEIVED)), & NPROCS).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 ) 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 ) 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 ) IF(BDC_MD)THEN #if ! defined(OLD_LOAD_MECHANISM) DM_MEM(MYID)=DM_MEM(MYID)+LOAD_RECEIVED #else DM_MEM(MYID)=LOAD_RECEIVED #endif 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 ) #if ! defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED #else LOAD_FLOPS( MSGSOU ) = LOAD_RECEIVED #endif 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif MD_MEM(LIST_SLAVES(i)) = & MD_MEM(LIST_SLAVES(i)) + & int(LOAD_INCR(i),8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(LIST_SLAVES(i)+1).EQ.0)THEN MD_MEM(LIST_SLAVES(i))=999999999_8 ENDIF #endif #if defined(OLD_LOAD_MECHANISM) END IF #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 ) MD_MEM(MSGSOU)=MD_MEM(MSGSOU)+int(LOAD_RECEIVED,8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(MSGSOU+1).EQ.0)THEN MD_MEM(MSGSOU)=999999999_8 ENDIF #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 ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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 #if ! defined(OLD_LOAD_MECHANISM) #if ! defined(IBC_TEST) 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) GOTO 112 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 #endif #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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif 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 #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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)), SLAVEF ) 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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) GOTO 111 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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)), NPROCS) & ) THEN RETURN ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE_LOAD(STEP_LOAD(INODE)),NPROCS))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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0), & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0), MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 112 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 CONTINUE 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) IF (WLOAD(i) < -0.5d0 ) THEN IF((MP.GT.0).AND.(LP.GE.2))THEN WRITE(MP,*)MYID,': Warning: negative load ', & WLOAD(i) ENDIF ENDIF 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)), & SLAVEF))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)), NPROCS ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL 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 #if ! defined(OLD_LOAD_MECHANISM) TO_BE_SENT=DELTA_LOAD-COST DELTA_LOAD=dble(0) #else TO_BE_SENT=LAST_LOAD_SENT-COST LAST_LOAD_SENT=LAST_LOAD_SENT-COST #endif 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 #if ! defined(OLD_LOAD_MECHANISM) DELTA_MEM=DELTA_MEM+TMP_M2 TO_BE_SENT=DELTA_MEM #else TO_BE_SENT=DM_LAST_MEM_SENT+TMP_M2 DM_LAST_MEM_SENT=DM_LAST_MEM_SENT+TMP_M2 #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, & TO_BE_SENT, & MYID, KEEP_LOAD, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF 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 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)), & SLAVEF)) THEN RETURN ENDIF FATHER=MUMPS_PROCNODE(PROCNODE(STEP(FATHER_NODE)),SLAVEF) 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)), & NPROCS).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) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_UPPER_PREDICT", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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)), NPROCS ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error 2 in SMUMPS_LOAD_SEND_MD_INFO", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif DO i = 1, NP_TO_UPDATE MD_MEM(P_TO_UPDATE(i))=MD_MEM(P_TO_UPDATE(i))+ & int(DELTA_MD( i ),8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(P_TO_UPDATE(i)+1).EQ.0)THEN MD_MEM(P_TO_UPDATE(i))=999999999_8 ENDIF #endif ENDDO #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif DEALLOCATE(DELTA_MD,P_TO_UPDATE,IPROC2POSINDELTAMD) 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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)),NPROCS).EQ.MYID)THEN IF(INODE.EQ.KEEP_LOAD(38))THEN GOTO 666 #if ! defined(OLD_LOAD_MECHANISM) ELSE IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': i did not find ',SON CALL MUMPS_ABORT() ENDIF GOTO 666 #endif 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 defined(NOT_ATM_POOL_SPECIAL) DOUBLE PRECISION TMP #endif IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0) & .AND.(INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF #if defined(NOT_ATM_POOL_SPECIAL) IF((INODE.LT.0).OR.(INODE.GT.N_LOAD))THEN MAX_MEM=huge(MAX_MEM) DO i=0,NPROCS-1 TMP=dble(TAB_MAXS(i))-(DM_MEM(i)+LU_USAGE(i)) IF(BDC_SBTR)THEN TMP=TMP-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF MAX_MEM=min(MAX_MEM,TMP) ENDDO RETURN ENDIF #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)), & NPROCS).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)), & NPROCS).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 ! defined(OLD_LOAD_MECHANISM) 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 #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)),NPROCS).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 #if defined(NOT_ATM_POOL_SPECIAL) IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N_LOAD ) THEN NODE = POOL(LPOOL-2-J) - N_LOAD ELSE NODE = POOL(LPOOL-2-J) ENDIF #else NODE=POOL(LPOOL-2-J) #endif 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)),NPROCS).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))), & NPROCS)) 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 MUMPS_5.1.2/src/zfac_front_LDLT_type1.F0000664000175000017500000004525413164366266017745 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NNEG, NPVW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS & , LRGROUPS & ) 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 !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR, NNEG, NPVW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION UU, SEUIL COMPLEX(kind=8) A( LA ) INTEGER, TARGET :: IW( LIW ) 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 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 LOGICAL LASTBL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION,ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok INTEGER :: OMP_NUM COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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 IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU SEUIL_LOC = SEUIL ENDIF PIVOT_OPTION = KEEP(468) 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(BEGS_BLR) 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 (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 IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTBL = .FALSE. IF (KEEP(201).EQ.1) THEN IDUMMY = -8765 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 PIVOT_OPTION = 3 CNT_NODES = CNT_NODES + 1 CALL INIT_STATS_FRONT(NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL INIT_STATS_FRONT(-NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1FR) ENDIF IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL ZMUMPS_FAC_I_LDLT(NFRONT,NASS,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEG, 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IF (IFLAG.LT.0) GOTO 500 IF(KEEP(109).GT. 0) THEN IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE & +IW(IOLDPS+5+XSIZE) PIVNUL_LIST(KEEP(109)) = IW(IWPOSP2) ENDIF ENDIF IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN NPVW = NPVW + PIVSIZ IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) 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), & KEEP(253), & PIVOT_OPTION, IEND_BLR & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. (.NOT. COMPRESS_PANEL) .OR. & (KEEP(485).EQ.0) & ) & ) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,IEND_BLR,INODE,A,LA, & LDA, POSELT, & KEEP,KEEP8, & PIVOT_OPTION, .FALSE.) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,NASS,INODE,A,LA, & LDA, POSELT, & KEEP,KEEP8, PIVOT_OPTION, .TRUE.) ELSE CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 1, 1) NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(8), KEEP(477) & ) IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V',1) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR,'V', & NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 IF (COMPRESS_CB) THEN CALL ZMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, NPARTSCB+NPARTSASS, & BEGS_BLR, NPARTSCB+NPARTSASS, NPARTSASS, & DKEEP(8), NASS, NFRONT-NASS, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, STEP_STATS(INODE), 1, & .FALSE., 0, KEEP(484)) END IF CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NFRONT-NASS, & KEEP(50), INODE, NASS-NPIV ) CALL STATS_COMPUTE_FLOP_FRONT_TYPE1(NFRONT, NASS, NPIV, & KEEP(50), INODE) LOC_LR_MODULE_TIME = dble(TTOT2-TTOT1)/dble(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (COMPRESS_PANEL) THEN IF ( PIVOT_OPTION.NE.3 & ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_FACTO_NIV1" CALL MUMPS_ABORT() ENDIF ELSE 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) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 490 CONTINUE write(*,*) 'Allocation problem in BLR routine & ZMUMPS_FAC_FRONT_LDLT_TYPE1: ', & 'not enough memory? memory requested = ' , IERROR 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC1_LDLT END MODULE ZMUMPS_FAC1_LDLT_M MUMPS_5.1.2/src/ssol_fwd.F0000664000175000017500000001215513164366263015460 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, & NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, 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_OOC IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB, LNA INTEGER SLAVEF, MYLEAF, COMM, MYID INTEGER INFO( 40 ), 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 NA( LNA ), NE_STEPS( KEEP(28) ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK_S(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 #if defined(RHSCOMP_BYROWS) REAL, intent(inout) :: RHSCOMP(NRHS,LRHSCOMP) #else REAL, intent(inout) :: RHSCOMP(LRHSCOMP,NRHS) #endif LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGSOU, DUMMY(1) LOGICAL FLAG INTEGER NBFIN, MYROOT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE INTEGER I INTEGER III, NBROOT,LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 DO I = 1, KEEP(28) NSTK_S(I) = NE_STEPS(I) ENDDO PTRICB = 0 CALL MUMPS_INIT_POOL_DIST(N, LEAF, MYID, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID, & SLAVEF, NA, LNA, KEEP, STEP, & PROCNODE_STEPS) NBFIN = SLAVEF IF ( MYROOT .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 MYLEAF = LEAF - 1 III = 1 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, III, 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 .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_SOLVE_NODE( INODE, BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, III, 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, & MYROOT, INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 .OR. 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.1.2/src/sfac_mem_alloc_cb.F0000664000175000017500000001603113164366262017224 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, IFLAG, IERROR ) USE SMUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, 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 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 LOGICAL DONE 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)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF IF (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 DONE =.FALSE. IF ((IPTRLU.LT.LREQCB_WISHED).OR.(LRLU.LT.LREQCB_WISHED)) THEN IF (LRLUS.LT.LREQCB_EFF) THEN GOTO 620 ELSE 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... SMUMPS_ALLOC_CB', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF DONE = .TRUE. ENDIF ENDIF IF (IWPOSCB-IWPOS+1 .LT. LREQ) THEN IF (DONE) GOTO 600 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... SMUMPS_ALLOC_CB', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF IF (IWPOSCB-IWPOS+1 .LT. LREQ) GOTO 600 ENDIF 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+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXP+1:IWPOSCB+1+KEEP(IXSZ))=-99999 #if ! defined(NO_XXNBPR) IW(IWPOSCB+1+XXNBPR)=0 #endif ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LREQCB_EFF KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQCB_EFF KEEP8(69) = min(KEEP8(71), KEEP8(69)) #if ! defined(OLD_LOAD_MECHANISM) CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #else #if defined (CHECK_COHERENCE) CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #else CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #endif #endif RETURN 600 IFLAG = -8 IERROR = LREQ RETURN 620 IFLAG = -9 CALL MUMPS_SET_IERROR(LREQCB_EFF - LRLUS, IERROR) RETURN END SUBROUTINE SMUMPS_ALLOC_CB MUMPS_5.1.2/src/cfac_process_band.F0000664000175000017500000002354613164366264017265 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & TNBPROCFILS, N, IW, LIW, A, LA, & 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 #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(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & TNBPROCFILS( 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 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 ) IBUFR = 10 #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, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, 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+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 TNBPROCFILS(STEP( INODE )) = NBPROCFILS # if ! defined(NO_XXNBPR) IW(IWPOSCB+1+XXNBPR)=NBPROCFILS # endif IW(IWPOSCB+1+XXLR)=LRSTATUS 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' INTEGER, INTENT(IN) :: INODE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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)), & SLAVEF ) # 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, & NBPROCFILS, N, IW, LIW, A, LA, & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/zmumps_ooc.F0000664000175000017500000036103613164366266016043 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' 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 #if ! defined (OOC_DEBUG) PTRFAC(STEP_OOC(INODE))=-777777_8 #endif 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 #if ! defined (OOC_DEBUG) PTRFAC(STEP_OOC(INODE))=-777777_8 #endif 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' 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))), & SLAVEF_OOC ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & SLAVEF_OOC ) 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)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),SLAVEF_OOC).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)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),SLAVEF_OOC).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) 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 #if ! defined(TEMP_VERSION_TO_FORCE_DATA_REINIT) & .OR. KEEP_OOC(50).NE.0 #endif & ) 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 #if ! defined(TEMP_VERSION_TO_FORCE_DATA_REINIT) & .OR. KEEP_OOC(50).NE.0 #endif & ) 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) & WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_STRUC_STORE_FILE_NAME' 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) & WRITE(ICNTL1,*) & 'PB allocation in ZMUMPS_STRUC_STORE_FILE_NAME' 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) & WRITE(ICNTL1,*) & 'PB allocation in ZMUMPS_OOC_OPEN_FILES_FOR_SOLVE' 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) 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.1.2/src/sfac_mem_compress_cb.F0000664000175000017500000002767013164366262020000 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INCLUDE 'mumps_headers.h' 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 SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE SMUMPS_SIZEFREEINREC 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) IMPLICIT NONE INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER N,LIW,KEEP28, & IWPOS,IWPOSCB,KEEP216,XSIZE INTEGER(8) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER IW(LIW),PTRIST(KEEP28), & STEP(N), PIMASTER(KEEP28) REAL 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 INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE INTEGER IXXP 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 IF ( STATE_NEXT .NE. S_FREE .AND. & (KEEP216.EQ.3.OR. & (STATE_NEXT .NE. S_NOLCBNOCONTIG .AND. & STATE_NEXT .NE. S_NOLCBCONTIG .AND. & STATE_NEXT .NE. S_NOLCBNOCONTIG38 .AND. & STATE_NEXT .NE. S_NOLCBCONTIG38))) THEN CALL SMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) 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 (RSIZE2SHIFT .NE. 0_8) THEN IF (PTRAST(STEP(INODE)).EQ.RCURRENT) & PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT IF (PAMASTER(STEP(INODE)).EQ.RCURRENT) & PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT 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 IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN IF ( KEEP216.eq.3) THEN WRITE(*,*) "Internal error 2 in SMUMPS_COMPRE_NEW" ENDIF 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) 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) 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) ELSE 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 INODE=IW(ICURRENT+XXN) IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) IF (STATE_NEXT.EQ.S_NOLCBCONTIG.OR. & STATE_NEXT.EQ.S_NOLCBNOCONTIG) THEN IW(ICURRENT+XXS)=S_NOLCLEANED ELSE IW(ICURRENT+XXS)=S_NOLCLEANED38 ENDIF 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 MUMPS_5.1.2/src/sana_reordertree.F0000664000175000017500000012340513164366262017164 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & 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 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(40) 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)), & SLAVEF))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)), & SLAVEF))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)), & SLAVEF))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)), & SLAVEF))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)),SLAVEF))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)),SLAVEF)))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)),SLAVEF)))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, & 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 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(40) 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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),SLAVEF) 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)),SLAVEF) 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)),SLAVEF))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)),SLAVEF) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE WRITE(*,*)ID,': INODE -> ',INODE,'DF =', & CUR_DEPTH_FIRST_RANK CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & SLAVEF))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & SLAVEF))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.1.2/src/dfac_process_message.F0000664000175000017500000010314513164366263017777 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 40 ) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, 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(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,SLAVEF, & 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(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, NBPROCFILS, & N, IW, LIW, A, LA, & 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, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, COMP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF) 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)), & SLAVEF ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF)) 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)),SLAVEF) & ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' 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(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/mumps_metis.c0000664000175000017500000001006413164366240016227 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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; } #endif MUMPS_5.1.2/src/cfac_asm_master_ELT_m.F0000664000175000017500000016333713164366265020002 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,NBPROCFILS, 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 MUMPS_BUILD_SORT_INDEX_ELT_M USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N,LIW,NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS 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))) LOGICAL SON_LEVEL2 COMPLEX, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR COMPLEX DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NBPROCFILS(KEEP(28)), NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INTEGER ETATASS LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE 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 INTEGER(8) NFRONT8, LAELL8 INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC INTEGER(8) LSTK8, SIZFR8 INTEGER SIZFI, NCB 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 NCOLS, NROWS, LDA_SON INTEGER NELIM, & IORG, IBROT 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, POINTER :: SON_IWPOS INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC 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 COMPRESSCB =.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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 LREQ_OOC = 0 IF (KEEP(201).EQ.1) 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) 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, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, 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)), & SLAVEF))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) 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 NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress CMUMPS_FAC_ASM_NIV1_ELT' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) #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=3000 !$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 NUMROWS = NFRONT8 TOPDIAG = max(KEEP(7), KEEP(8), KEEP(57), KEEP(58))-1 !$ 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 NASS = NASS1 PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = SON_IW(ISTCHK + 3+KEEP(IXSZ)) 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 COMPRESSCB = & ( SON_IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( SON_IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF 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) THEN K2 = K1 + LSTK - 1 IF (COMPRESSCB) 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 SIZFR8 = int(NELIM,8) * int(NELIM,8) END IF K2 = K1 + NELIM - 1 ENDIF OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) 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) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR8 ELSE LCB = int(LDA_SON,8) * int(K2-K1+1,8) ENDIF IF (LCB .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB & ) 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(SSARBR, MYID, N, ISTCHK, & IACHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 END DO 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 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 280 CONTINUE INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING CMUMPS_ASM_NIV1_ELT' ENDIF GOTO 500 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 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, & NBPROCFILS, 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(40) 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 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))) COMPLEX A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR COMPLEX DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)), 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 INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 ETATASS 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(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 :: 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)) COMPRESSCB=.FALSE. ETATASS = 0 IN = INODE NBPROCFILS(STEP(IN)) = 0 NSTEPS = NSTEPS + 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)), & SLAVEF) .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) MAXFRW = max0(MAXFRW, NFRONT) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 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)), & SLAVEF) 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)), & SLAVEF) 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)), & SLAVEF) 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) 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) 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) 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) GOTO 275 CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, 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) 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) #if defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) IF ( KEEP(73) .EQ. 0 ) THEN #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 defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) ENDIF #endif #endif 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 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress CMUMPS_FAC_ASM_NIV2_ELT' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), IW(IOLDPS+XXNBPR)) #endif 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 = max(int(KEEP(361)/2,8), !$ & (LAELL8+NOMP-1) / NOMP ) !$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 ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 !$ 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 + KEEP(IXSZ) + 3) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) 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) + 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) + A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (NSLSON.EQ.0) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF IF (LCB .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & COMPRESSCB & ) 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, & 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), & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 280 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, WORKSPACE TOO SMALL DURING CMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) 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.1.2/src/zfac_process_blocfacto_LDLT.F0000664000175000017500000010630413164366265021156 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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_OOC USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_FAC_LR USE ZMUMPS_ANA_LR USE ZMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ), 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), 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 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL, LD_BLOCFACTO INTEGER(8) LAELL, POSBLOCFACTO INTEGER(8) POSELT 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 INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW 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(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPivDummy LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRELAY_INFO LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR LOGICAL :: SEND_LR INTEGER :: XSIZE, CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: SEND_LR_INT, 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 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL 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 INTEGER T1, T2, COUNT_RATE, LWORK DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, MY_NUM 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF 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 ( SEND_LR ) THEN LAELL = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LAELL = int(NPIV,8) * int(NCOL,8) ENDIF IF ( NPIV.GT.0 ) THEN IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS, IERROR) IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN ZMUMPS_PROCESS_SYM_BLOCFACTO, & REAL WORKSPACE TOO SMALL" GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ZMUMPS_PROCESS_SYM_BLOCFACTO,", & " LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS,IERROR) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN ZMUMPS_PROCESS_SYM_BLOCFACTO, & INTEGER WORKSPACE TOO SMALL" IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(70) = KEEP8(70) - LAELL KEEP8(71) = KEEP8(71) - LAELL ENDIF KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLUS) IF ( NPIV.EQ.0 ) THEN IPIV = 1 LD_BLOCFACTO = NPIV+NELIM ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR ) 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_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1))) ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2)) CALL ZMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, KEEP(470), & BEGS_BLR_LM(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 SRC_DESCBAND = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTRIST(STEP(INODE))+XXNBPR)) DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) #else DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) POSELT = PTRAST(STEP(INODE)) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) ELSE CALL ZMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS) 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 PIVI = abs(IW(IPIV+I-1)) 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(IPOS), NCOL1, A(KPOS), NCOL1) ENDDO IF (.NOT.SEND_LR) 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 (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T1) ENDIF CALL ztrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A(POSELT+int(NPIV1,8)), NCOL1 ) IF (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_TRSM_TIME = ACC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF IF (.NOT.SEND_LR) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 DO I = 1, NROW1 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = & A(LPOS: LPOS+int(NPIV-1,8)) LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF LPOS = POSELT + int(NPIV1,8) DPOS = POSBLOCFACTO I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(IPIV+I-1) .GT. 0) THEN A11 = ONE/A(DPOS) CALL zscal( NROW1, A11, A(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 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A11*A(LPOS1)+A12*A(LPOS1+1_8) MULT2 = A12*A(LPOS1)+A22*A(LPOS1+1_8) A(LPOS1) = MULT1 A(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 IF (SEND_LR) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 ENDIF IF (NPIV.GT.0) THEN IF (NROW1.LE.0) CALL MUMPS_ABORT() IF (SEND_LR) 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 (KEEP(489).EQ.1) 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 ELSE CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_MASTER ENDIF CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL) 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 CALL ZMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), & .TRUE., .TRUE., .TRUE., NPARTSASS_MASTER, & 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)) write(6,*) 'ERROR 2 allocate temporary BLR blocks during', & ' ZMUMPS_PROCESS_SYM_BLOCFACTO', IERROR GOTO 700 ENDIF CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS)) CALL SYSTEM_CLOCK(T1) MY_NUM=0 #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, DKEEP(8), KEEP(473), BLR_LS, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #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. & ( .NOT. SEND_LR .OR. (NPIV.EQ.0) .OR. & (KEEP(485).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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN IF (SEND_LR) THEN IF (NELIM.GT.0) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL zgemm('N','N', NELIM,NROW1,NPIV,ALPHA, & A(UPOS),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ENDIF #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL ZMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL1, NROW1, & POSBLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM+1, BLR_LM, NPIV1, & BEGS_BLR_LS, NB_BLR_LS+1, BLR_LS, 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR(1:MAXI_CLUSTER,MY_NUM*MAXI_CLUSTER+1), & MAXI_CLUSTER, & KEEP(481), DKEEP(8), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_UPDT_TIME = ACC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_LS, & 0, NPARTSCB, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, & .FALSE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS, & CURRENT_BLR, 'V', NCOL1, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (KEEP(201).eq.1) 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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF ENDIF CALL DEALLOC_BLR_PANEL (BLR_LM, NB_BLR_LM, KEEP8, .FALSE.) DEALLOCATE(BLR_LM) IF (NSLAVES_PREC.GT.0) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL,BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF ELSE LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL zgemm('N','N', NCOL-NPIV,NROW1,NPIV,ALPHA,A(UPOS),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) DPOS = POSELT + int(NCOL1 - NROW1,8) 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( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A(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( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, ONE, & A( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO 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. SEND_LR ) THEN LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) 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 ) CALL ZMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & SEND_LR, BLR_LS, IPANEL, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 defined(IBC_TEST) WRITE(*,*) MYID,":Send2slave worked" #endif 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 ( NPIV.GT. 0 .AND. SEND_LR ) THEN IF (NSLAVES_PREC.GT.0) THEN IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8, .TRUE.) ENDIF LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( NPIV .NE. 0 ) THEN IF (allocated(UIP21K)) DEALLOCATE( UIP21K ) ENDIF IOLDPS = PTRIST(STEP(INODE)) IF (LASTBL) THEN IF (KEEP(486).NE.0) THEN IF (SEND_LR) 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)), SLAVEF ) 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 (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN CALL ZMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, & BEGS_BLR_COL, NB_BLR_COL, NPARTSASS_MASTER, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., 0, KEEP(484)) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 (SEND_LR) 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, .TRUE.) 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 (KEEP(489).EQ.1) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if defined(IBC_TEST) write(6,*) MYID,' :Exiting ZMUMPS_PROCESS_SYM_BLOCFACTO for &INODE=', INODE #endif RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.1.2/src/mumps_comm_ibcast.F0000664000175000017500000000070513164366241017333 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE MUMPS_COMM_IBC_RETURN() RETURN END SUBROUTINE MUMPS_COMM_IBC_RETURN MUMPS_5.1.2/src/cini_defaults.F0000664000175000017500000013454313164366266016462 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 SIZE_INT, SIZE_REAL_OR_DOUBLE ! Type must match MUMPS_INT 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(40), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(40), INFOG(40) 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) has default value 0.01 and is used for C threshold pivoting. Values greater than 1.0 C are treated as 1.0, and less than zero as zero. 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 only used combined with null pivot row C detection (ICNTL(24) .eq. 1) and to Rank-Revealing (RR) option. C It must be set to the absolute threshold for numerical pivoting. 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 row/column C is smaller than a threshold. Let MACHEPS be the machine precision and C ||.|| be the infinite norm. C The computed threshold value for postponing pivots in case of RR on root C is stored in "SEUIL" and then "SEUIL_LDLT_NIV2" C which are identical in current version. C This absolute threshold value is stored in DKEEP(9). C C The absolute value to detect a null pivot (when ICNTL(24) .NE.0) C is stored in DKEEP(1) and must be smaller than C SEUIL when combined with RR on root. C C IF (ICNTL(16).NE.0) THEN C RR on root is active C IF (CNTL3 .LT. ZERO) THEN C SEUIL = abs(CNTL(3)) C ELSE IF (CNTL3 .GT. ZERO) THEN C SEUIL = CNTL3*ANORMINF C ELSE ! (CNTL(3) .EQ. ZERO) THEN C SEUIL = N*EPS*ANORMINF ! standard articles C ENDIF C IF (ICNTL(24).NE.0) THEN C null pivot detection C IF (CNTL(6).GT.0.AND.CNTL(6).LT.1) THEN C we want DKEEP(1) < SEUIL C DKEEP(1) = SEUIL*CNTL(6) ! ideally it could be SEUIL*CNTL(6) C ELSE C DKEEP(1) = SEUIL* 0.01E0 C ENDIF C ENDIF C C ELSE (ONLY NULL PIVOT detection is active) C we keep stratgy used in MUMPS_4.10 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 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 the row/column (except the pivot) is set to zero C and the pivot is set to 1 C Default is 0. C Note that in the symmetric parallel case, some elements of the column C are not available on the local processor and cannot be set to 0 easily. C In such cases, in the current version, C -the corresponding pivot is first set C to a large value instead of 1, even when CNTL(5) < 0. C -Updating of the off diag block is done with this large C value C -diagonal value is then reset to zero C C CNTL(6) expresses the ratio between C absolute criterion for null pivots and absolute criterion C for posponing pivots before partial pivoting analysis of pivots. C Typically C let SEUIL = F(CNTL(3)), and 0 < CNTL(6) < 1 C SEUIL is stored in DKEEP(9) C if ||Pivot row|| < SEUIL*CNTL(6) then C null pivot row detected (correct only if LDLT C for LU pivot_col must be checked too) C else if || Pivot_Row || < SEUIL then C pospone pivot C else C partial threshold pivoting C endif 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 default = 0 C else C if distributed matrix entry then C default = 7 C else C if (mc64 called or mc77 based matching) then C default=-2 and ordering is computed during analysis C else C default = 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 define 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 set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is automatically C set to 5 and ICNTL(6) is set to -2 (we need the scaling factors C 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 Authorizing extra root spliting C during analysis might be interesting C to further split the root node C (combined for example with C null pivot detection option ICNTL(24)=1 OR ICNTL(16)) 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 (or 30, or 5 depending on NSLAVES, C SYM,...) and is the value for memory relaxation C so called "PERLU" in the following. 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). 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, k=1,NRHS is C considered to be the solution corresponding to the Schur C variables. It is injected in CMUMPS, that computes the solution C on the "internal" problem during the backward 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 performed by the solver. C Default value is -24. 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 C ICNTL(35) : Block low rank (BLR) factorization C Default value is 0 C 0 = BLR is not activated C 1 = BLR activated with grouping based C on inherited clustering done during analysis C Other values are treated as zero C Note that this functionality is currently incompatible with elemental matrices C (ICNTL(5) = 1) and with forward elimination during factorization (ICNTL(32) = 1). C C ICNTL(38) not used in this version C C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 40 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 arry 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. 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 Note that it does not include null pivots C that might have been C further detected on the root (ICNTL(16).NE.0). 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 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=========================== 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:40) = 0 INFOG(1:40) = 0 ICNTL(1:40) = 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 CNTL(6) = -1.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 IF (NSLAVES .GT. 4) THEN ICNTL(14) = 30 ELSE ICNTL(14) = 20 END IF C Minimum size of the null space ICNTL(15) = 0 C Do not look for rank/null space basis ICNTL(16) = 0 C Max size of null space ICNTL(17) = 0 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 --------- Non documented ICNTL options C Old or new symbolic factorization ICNTL(39) = 1 ICNTL(40) = 0 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 C KEEP(11) = 2147483646 KEEP(11) = huge(KEEP(11)) KEEP(24) = 18 KEEP(68) = 0 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 500 KEEP(58) = 250 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 KEEP(17) = 0 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 !write(6,*) ' TEMPORARY new splitting active, K79=', KEEP(79) 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(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 #if ! defined(NO_XXNBPR) KEEP(121)=-999999 #endif KEEP(122)=15 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)=50 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 DKEEP(10) = 1000.0E0 ! > 0 : GAP IF(NSLAVES.LE.8)THEN KEEP(238)=12 ELSE KEEP(238)=7 ENDIF KEEP(234)= 1 KEEP(235)=-1 DKEEP(3)=-5.0E0 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) = 0 KEEP(266) = 0 KEEP(267) = 0 KEEP(350) = 1 KEEP(351) = 0 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 KEEP(468) = 3 KEEP(469) = 1 KEEP(470) = 1 KEEP(471) = -1 KEEP(480) = 0 KEEP(479) = 1 KEEP(478) = 0 KEEP(474) = 0 KEEP(481) = 0 KEEP(482) = 0 KEEP(472) = 1 KEEP(473) = 0 KEEP(475) = 0 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 50 KEEP(484) = 50 KEEP(485) = 1 ! (1 promote factors) 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(489) = 0 KEEP(490) = 128 KEEP(491) = 1000 KEEP(492) = 1 KEEP(82) = 30 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 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%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 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.1.2/src/mumps_numa.c0000664000175000017500000000063513164366240016051 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html * */ int mumps_numa_return() { return 0; } MUMPS_5.1.2/src/cana_lr.F0000664000175000017500000003527613164366265015252 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1)) 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)) 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 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) :: LRGROUPS(N), VLIST(NV), TRACE(N) 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 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, INTENT(INOUT) :: LRGROUPS(N) INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1)) NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO PARTPTR(1)=1 CNT = 0 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 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 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 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 INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP)) ALLOCATE(PERM(NSEP)) ALLOCATE(IPERM(NSEP)) ALLOCATE(SIZES(NPARTS)) ALLOCATE(PARTPTR(NPARTS+1)) 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)) 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 END MODULE CMUMPS_ANA_LR MUMPS_5.1.2/src/zfac_process_maprow.F0000664000175000017500000014262513164366265017716 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif IMPLICIT NONE INCLUDE 'zmumps_root.h' #if ! defined(NO_FDM_MAPROW) #endif TYPE (ZMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) 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 ) 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 COMPRESSCB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE, TYPESPLIT INTEGER KEEP253_LOC #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 IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE_PERE)), & SLAVEF) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in ZMUMPS_MAPLIG' 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)), & SLAVEF ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) write(LP,*) MYID, & ' : PB allocation NBROW in ZMUMPS_MAPLIG' 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)), & SLAVEF) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 7 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO #endif ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 9 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO_SYM #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM 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( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) 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 COMPRESSCB=(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 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(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & A(PTRAST(STEP(ISON))), I, PDEST, PDEST_MASTER, & COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, COMPRESSCB, & KEEP253_LOC ) 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF ITYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), SLAVEF) 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, MYID, COMM, KEEP,KEEP8, DKEEP,ITYPE & ) 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 &) 600 CONTINUE DEALLOCATE(PERM) 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 40 ), 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 INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ) 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 NBPROCFILS( KEEP(28) ) 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 ) 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) :: APOS, POSROW, ASIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL COMPRESSCB INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM 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)), & SLAVEF ) 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(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ': PB allocation PERM in ZMUMPS_MAPLIG_FILS_NIV1' 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( 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)) 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 COMPRESSCB=(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 DECR=1 NBPROCFILS(STEP(INODE_PERE)) = & NBPROCFILS(STEP(INODE_PERE)) - DECR NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR #if ! defined(NO_XXNBPR) IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE_PERE)), & IW(PTLUST(STEP(INODE_PERE))+XXNBPR)) IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXNBPR)) #endif DO II = 1,NROWS_TO_STACK IROW_SON=PERM(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 (COMPRESSCB) THEN IF (NELIM.EQ.0) THEN POSROW = PAMASTER(STEP(ISON)) + & int(IROW_SON,8)*int(IROW_SON-1,8)/2_8 ELSE POSROW = PAMASTER(STEP(ISON)) + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ENDIF ELSE POSROW = PAMASTER(STEP(ISON)) + & 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 CALL ZMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF) ENDDO IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (COMPRESSCB) THEN POSROW = PAMASTER(STEP(ISON)) & + 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 = PAMASTER(STEP(ISON)) + & 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).GT. 0 ) THEN CALL ZMUMPS_COMPUTE_MAXPERCOL( & A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253), & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB, & NELIM+NBROW(1)) ELSE CALL ZMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF CALL ZMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXNBPR)) IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 #endif & ) 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 ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE_PERE)), & IW(PTLUST(STEP(INODE_PERE))+XXNBPR)) IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 #endif & ) THEN CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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)) APOS = PAMASTER(STEP(ISON)) 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 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(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & A(APOS), I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & COMPRESSCB, KEEP(253)) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ZMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) 600 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(MAP) DEALLOCATE(PERM) DEALLOCATE(SLAVES_PERE) RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 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, NBPROCFILS, & 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL & ) USE ZMUMPS_BUF, ONLY: ZMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE ZMUMPS_LOAD, ONLY : ZMUMPS_LOAD_POOL_UPD_NEW_POOL INTEGER ICNTL(40) 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(inout) :: NBPROCFILS( KEEP(28) ) 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 INTEGER, intent(in) :: FILS(N) 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 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 LOGICAL :: COMPRESSCB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) #if ! defined(NO_XXNBPR) INTEGER :: INBPROCFILS_SON #endif 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 NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - DECR #if ! defined(NO_XXNBPR) IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR #endif IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR #if ! defined(NO_XXNBPR) IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR #endif 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 COMPRESSCB = (IW(ISTCHK+XXS).EQ.S_CB1COMP) CALL MUMPS_GETI8(SIZFR, IW(ISTCHK+XXR)) IF (IW(ISTCHK+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 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 ) 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 ) ENDIF ENDIF DO II = 1,NROWS_TO_STACK 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 ( COMPRESSCB ) THEN IF (NBCOLS - NROW .EQ. 0 ) THEN ITMP = IROW_SON POSROW = PTRAST(STEP(ISON))+ & int(ITMP,8) * int(ITMP-1,8) / 2_8 ELSE ITMP = IROW_SON + NBCOLS - NROW POSROW = PTRAST(STEP(ISON)) & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ENDIF ELSE POSROW = PTRAST(STEP(ISON)) + 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 CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.COMPRESSCB).AND.(IS_ofType5or6) ) THEN CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) ENDIF ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV 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) & .OR. & ( (KEEP(50).NE.0).and. (.NOT.COMPRESSCB) ) & ) & ) THEN CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - & NROWS_TO_STACK #if ! defined(NO_XXNBPR) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK #endif EXIT ELSE CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - 1 #if ! defined(NO_XXNBPR) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 #endif ENDIF ENDIF ENDDO IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (COMPRESSCB) THEN WRITE(*,*) "Error 1 in PARPIV/ZMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = PTRAST(STEP(ISON))+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 .NE. 0 ) THEN CALL ZMUMPS_COMPUTE_MAXPERCOL( & A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, LMAP_LOC-NBROW(1)+1-KEEP253_LOC, & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB,ITMP) ELSE CALL ZMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF CALL ZMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB #if ! defined(NO_XXNBPR) 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 #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL( NBPROCFILS(STEP(ISON)), & IW(INBPROCFILS_SON) ) IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN #endif 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 ZMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, & ISTCHK_LOC, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL( NBPROCFILS(STEP(IFATH)), & IW(PTLUST(STEP(IFATH))+XXNBPR) ) IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(IFATH)) .EQ. 0 #endif & ) THEN CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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.1.2/src/zooc_panel_piv.F0000664000175000017500000002757513164366266016666 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/cfac_mem_alloc_cb.F0000664000175000017500000001603413164366264017211 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, IFLAG, IERROR ) USE CMUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, 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 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 LOGICAL DONE 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)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF IF (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 DONE =.FALSE. IF ((IPTRLU.LT.LREQCB_WISHED).OR.(LRLU.LT.LREQCB_WISHED)) THEN IF (LRLUS.LT.LREQCB_EFF) THEN GOTO 620 ELSE 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... CMUMPS_ALLOC_CB', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF DONE = .TRUE. ENDIF ENDIF IF (IWPOSCB-IWPOS+1 .LT. LREQ) THEN IF (DONE) GOTO 600 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... CMUMPS_ALLOC_CB', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF IF (IWPOSCB-IWPOS+1 .LT. LREQ) GOTO 600 ENDIF 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+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXP+1:IWPOSCB+1+KEEP(IXSZ))=-99999 #if ! defined(NO_XXNBPR) IW(IWPOSCB+1+XXNBPR)=0 #endif ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LREQCB_EFF KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQCB_EFF KEEP8(69) = min(KEEP8(71), KEEP8(69)) #if ! defined(OLD_LOAD_MECHANISM) CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #else #if defined (CHECK_COHERENCE) CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #else CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #endif #endif RETURN 600 IFLAG = -8 IERROR = LREQ RETURN 620 IFLAG = -9 CALL MUMPS_SET_IERROR(LREQCB_EFF - LRLUS, IERROR) RETURN END SUBROUTINE CMUMPS_ALLOC_CB MUMPS_5.1.2/src/zfac_front_LDLT_type2.F0000664000175000017500000006562113164366266017746 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NOFFW, & NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'zmumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 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(40), 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), & 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)), NBPROCFILS(KEEP(28)), & 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 INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTBL, LR_ACTIVATED 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 HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER PIVOT_OPTION 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(BLR_L) IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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 PIVOT_OPTION = MIN(2,KEEP(468)) IF (UUTEMP == 0.0D0 .AND. KEEP(201).NE.1) THEN 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 IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. NULLIFY(BEGS_BLR) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) 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 K263 = 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 IF (KEEP(201).EQ.1) THEN IDUMMY = -9876 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 CNT_NODES = CNT_NODES + 1 CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL SYSTEM_CLOCK(TTOT1FR) ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.2) PIVOT_OPTION=2 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 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 IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) 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,NOFFW,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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IF (IFLAG.LT.0) GOTO 490 IF(KEEP(109).GT. 0) THEN IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN IWPOSPIV = IOLDPS+IW(IOLDPS+1+XSIZE)+6 & +IW(IOLDPS+5+XSIZE) PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+XSIZE) ENDIF ENDIF IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN NPVW = NPVW + PIVSIZ IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. & ( (KEEP(485).EQ.0) .AND. (PIVOT_OPTION.GT.2) ) & ) & ) 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,IEND_BLR,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & PIVOT_OPTION, .FALSE.) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 2, 1) ENDIF IF (LR_ACTIVATED) THEN 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 GOTO 101 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V', 2) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 ENDIF 101 CONTINUE 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8,PIVOT_OPTION, .TRUE.) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) CALL MUMPS_ABORT() #if defined(BLR_MT) !$OMP PARALLEL #endif IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 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(8), KEEP(477) & ) IF (IFLAG.LT.0) GOTO 450 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 100 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (PIVOT_OPTION.LE.2) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & NASS, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) ELSE IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & NASS, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) END IF ENDIF CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 (KEEP(201).EQ.1) 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 500 480 CONTINUE write(*,*) 'Allocation problem in BLR routine & ZMUMPS_FAC_FRONT_LDLT_TYPE2: ', & 'not enough memory? memory requested = ' , IERROR 490 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, 1, INODE, & NELIM) CALL STATS_COMPUTE_FLOP_FRONT_TYPE2(NFRONT, NASS, KEEP(50), & INODE, NELIM) CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), & 2) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) 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.1.2/src/dfac_process_root2son.F0000664000175000017500000003232313164366263020137 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 40 ) 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 NBPROCFILS(KEEP(28)) 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 ) 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)),SLAVEF) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & SLAVEF ).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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), SLAVEF) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 7 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO #endif ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 9 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO_SYM #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, 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.1.2/src/zfac_process_contrib_type3.F0000664000175000017500000002467513164366265021201 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS,SLAVEF ) USE ZMUMPS_LOAD USE ZMUMPS_OOC IMPLICIT NONE INCLUDE 'zmumps_root.h' 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 ), NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)),SLAVEF COMPLEX(kind=8) A( LA ) INTEGER MYID INTEGER FILS( N ) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N ) INTEGER INTARR(KEEP8(27)) COMPLEX(kind=8) DBLARR(KEEP8(26)) 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 NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT))-1 #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) - 1 CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)),KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN #endif 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(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 NBPROCFILS(STEP( IROOT ) ) = -1 #if ! defined(NO_XXNBPR) KEEP(121)=-1 #endif ENDIF IF (KEEP(60) == 0) THEN CALL ZMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N, & IW, LIW, A, LA, & FILS, MYID, 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 ELSE PTRIST(STEP(IROOT)) = -55555 ENDIF 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, PTRIST, & PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, 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 ) CALL ZMUMPS_ASS_ROOT( 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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, PTRIST, & PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, 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 ) IF (KEEP(60).EQ.0) THEN CALL ZMUMPS_ASS_ROOT( 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( 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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.1.2/src/dfac_distrib_ELT.F0000664000175000017500000004731613164366263016770 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 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)) ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF 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 ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC)=ZERO ENDDO ENDIF 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 ARROW_ROOT = ARROW_ROOT + 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)==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) 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 ) ARROW_ROOT = ARROW_ROOT + NB_REC 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 (KEEP(38).ne.0) THEN DEALLOCATE(ELROOTPOS8) 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.1.2/src/mumps_io.c0000664000175000017500000004705713164366240015531 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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; /** * Forward declaration. Definition at the end of the file. */ /*MUMPS_INLINE int mumps_convert_2fint_to_longlong( MUMPS_INT *, MUMPS_INT *, long long *);*/ /* 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,flag_loc; #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",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",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 BLOCK(1:MAXI_CLUSTER,1) #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, BLOCK_PTR, !$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 = OMP_GET_THREAD_NUM() BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1) #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL CMUMPS_LRGEMM3('N', 'T', MONE, & BLR_L(J),BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, NFRONT, & IW2, & BLOCK_PTR, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_L(J), BLR_L(I), 'N', & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ & , (I.EQ.J) & ) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE CMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, POSBLOCFACTO, 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, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, POSBLOCFACTO COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(out) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), & MAXI_CLUSTER, 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) INTEGER, POINTER, 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) :: COMPRESS_MID_PRODUCT, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, 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_LM = NB_BLR_LM-CURRENT_BLR_LM NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS POSELTD = POSBLOCFACTO #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, 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 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 CMUMPS_LRGEMM3('N', 'T', MONE, & BLR_LM(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, 2, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, LD_BLOCFACTO, & IW2, & BLOCK, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LM(J), BLR_LS(I), & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, & .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, 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 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 CMUMPS_LRGEMM3('N', 'T', MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, 2, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, LD_BLOCFACTO, & IW2, & BLOCK, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LS(J), BLR_LS(I), & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, & (I.EQ.J)) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE CMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT SUBROUTINE CMUMPS_BLR_UPDATE_NELIM_VAR( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, CURRENT_BLR, & NELIM, SYM, NIV, FIRST_BLOCK LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(out) :: IFLAG, IERROR INTEGER, intent(in) :: ISHIFT COMPLEX, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL, IS INTEGER :: allocok 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 IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if defined(BLR_MT) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = FIRST_BLOCK-CURRENT_BLR, 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 write(*,*) 'Allocation problem in BLR routine & CMUMPS_BLR_UPDATE_NELIM_VAR: ', & 'not enough memory? memory requested = ', IERROR 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 IF (SYM.EQ.0) THEN 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) ELSE POSELT_TOP = POSELT + int(NFRONT,8) & * int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) & + int((BEGS_BLR_L(CURRENT_BLR)-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('T' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDIF ENDDO ENDIF 100 CONTINUE #if defined(BLR_MT) !$OMP END SINGLE #endif END SUBROUTINE CMUMPS_BLR_UPDATE_NELIM_VAR 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, K470, & COMPRESS_MID_PRODUCT, TOLEPS, 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, K470, & NELIM, NIV, SYM INTEGER, intent(out) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, 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 CHARACTER(len=1) :: TRANSB1 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 write(*,*) 'Allocation problem in BLR routine & CMUMPS_BLR_UPDATE_TRAILING: ', & 'not enough memory? memory requested = ', IERROR 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) IF (SYM.EQ.0) THEN IF (K470.EQ.1) THEN TRANSB1 = 'N' ELSE TRANSB1 = 'T' ENDIF CALL CMUMPS_LRGEMM3(TRANSB1, 'T', MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, & KPERCENT, MID_RANK, BUILDQ) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), & TRANSB1, & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) ELSE CALL CMUMPS_LRGEMM3('N', 'T', MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, & KPERCENT, MID_RANK, BUILDQ) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), 'N', & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING SUBROUTINE CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & LD_OR_NPIV, K470, & BEG_I_IN, END_I_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) :: NFRONT, 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) :: LD_OR_NPIV, K470 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN INTEGER :: IP, M, N, BIP, BEG_I, END_I #if defined(BLR_MT) INTEGER :: LAST_IP, CHUNK #endif INTEGER :: K, I INTEGER(8) :: POSELT_BLOCK, NFRONT8, 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 NFRONT8 = int(NFRONT,8) LD_BLK_IN_FRONT = NFRONT8 BIP = BEGS_BLR_FIRST_OFFDIAG #if defined(BLR_MT) LAST_IP = BEG_I CHUNK = 1 !$OMP PARALLEL DO PRIVATE(POSELT_BLOCK, M, N, K, I) !$OMP& FIRSTPRIVATE(BIP, LAST_IP) SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if defined(BLR_MT) DO I = 1, IP - LAST_IP IF (DIR .eq. 'V') THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ELSE IF (K470.EQ.1) THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ELSE BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N ENDIF ENDIF ENDDO LAST_IP = IP #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LD_OR_NPIV) THEN POSELT_BLOCK = POSELT + NFRONT8*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ELSE POSELT_BLOCK = POSELT +NFRONT8*int(LD_OR_NPIV,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LD_OR_NPIV,8)*int(BIP-1-LD_OR_NPIV,8) LD_BLK_IN_FRONT=int(LD_OR_NPIV,8) ENDIF ELSE POSELT_BLOCK = POSELT + & NFRONT8*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 K = BLR_PANEL(IP-CURRENT_BLR)%K IF ((BLR_PANEL(IP-CURRENT_BLR)%ISLR).AND. & (BLR_PANEL(IP-CURRENT_BLR)%LRFORM.EQ.1)) THEN IF (K.EQ.0) THEN IF (K470.NE.1.OR.DIR .eq. 'V') THEN DO I = 1, M 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 = 1, N A(POSELT_BLOCK+int(I-1,8)*NFRONT8: & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (K470.NE.1.OR.DIR .eq. 'V') THEN 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)) ELSE CALL cgemm('N', 'N', M, N, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & ZERO, A(POSELT_BLOCK), NFRONT) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (K470.NE.1.OR.DIR .eq. 'V') THEN DO I = 1, M 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 = 1, N A(POSELT_BLOCK+int(I-1,8)*NFRONT8: & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if !defined(BLR_MT) IF (DIR .eq. 'V') THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ELSE IF (K470.EQ.1) THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ELSE BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%N ENDIF ENDIF #endif END DO #if defined(BLR_MT) !$OMP END PARALLEL DO #endif END SUBROUTINE CMUMPS_DECOMPRESS_PANEL SUBROUTINE CMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR_L, NB_BLR_L, & BEGS_BLR_U, NB_BLR_U, NPARTSASS_U, & TOLEPS, NASS, NROW, & SYM, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, INODE, NIV, & LBANDSLAVE, ISHIFT,KPERCENT) INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, INODE INTEGER, INTENT(IN) :: NIV, NROW, KPERCENT INTEGER :: MAXI_CLUSTER, LWORK, SYM, NASS, & NB_BLR_L, NB_BLR_U, NPARTSASS_U REAL,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U COMPLEX :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER) REAL,DIMENSION(:) :: RWORK COMPLEX, DIMENSION(:) :: WORK, TAU INTEGER, DIMENSION(:) :: JPVT INTEGER :: M, N, NCB, BEGLOOP, RANK, MAXRANK, FRONT_CB_BLR_SAVINGS INTEGER :: INFO, I, J, JJ, IB, JDEB, IS INTEGER :: allocok, MREQ INTEGER(8) :: POSELT_BLOCK DOUBLE PRECISION :: HR_COST, BUILDQ_COST, CB_DEMOTE_COST, & CB_PROMOTE_COST INTEGER T1, T2, COUNT_RATE DOUBLE PRECISION :: LOC_PROMOTING_TIME DOUBLE PRECISION :: LOC_CB_DEMOTING_TIME COMPLEX, ALLOCATABLE :: R(:,:) COMPLEX :: ONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) LOC_PROMOTING_TIME = 0.0D0 LOC_CB_DEMOTING_TIME = 0.0D0 CB_DEMOTE_COST = 0.0D0 CB_PROMOTE_COST = 0.0D0 allocate(R(MAXI_CLUSTER,MAXI_CLUSTER),stat=allocok) IF (allocok .GT. 0) THEN MREQ=MAXI_CLUSTER*MAXI_CLUSTER write(*,*) 'Allocation problem in BLR routine & CMUMPS_FAKE_COMPRESS_CB: ', & 'not enough memory? memory requested = ', MREQ CALL MUMPS_ABORT() ENDIF FRONT_CB_BLR_SAVINGS = 0 NCB = NFRONT - NASS IF (NCB.LE.0) RETURN IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF DO J = NPARTSASS_U+1, NB_BLR_U IF (NIV.EQ.1) THEN IF (SYM.GT.0) THEN BEGLOOP = J ELSE BEGLOOP = NPARTSASS_U + 1 ENDIF ELSE BEGLOOP = 2 ENDIF IF ((BEGS_BLR_U(J+1)+IS).LE.NASS+1) CYCLE JDEB = max(BEGS_BLR_U(J)+IS,NASS+1) N = BEGS_BLR_U(J+1)+IS-JDEB DO I = BEGLOOP, NB_BLR_L CALL SYSTEM_CLOCK(T1) JPVT = 0 M = BEGS_BLR_L(I+1)-BEGS_BLR_L(I) POSELT_BLOCK = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(I)-1),8) & + int(JDEB - 1,8) DO IB=1,M IF((I.EQ.J).AND.(SYM.GT.0).AND.(NIV.EQ.1)) THEN BLOCK(IB,1:IB) = & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : & POSELT_BLOCK+ & int((IB-1),8)*int(NFRONT,8)+int(IB-1,8) ) BLOCK(1:IB-1,IB) = BLOCK(IB,1:IB-1) ELSE BLOCK(IB,1:N) = & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8)+int(N-1,8) ) ENDIF END DO MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL CMUMPS_TRUNCATED_RRQR( M, N, BLOCK(1,1), & MAXI_CLUSTER, JPVT(1), TAU(1), WORK(1), N, & RWORK(1), TOLEPS, RANK, MAXRANK, INFO ) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_CB_DEMOTING_TIME = LOC_CB_DEMOTING_TIME & + DBLE(T2-T1)/DBLE(COUNT_RATE) IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK & IN CB (FAKE COMPRESSION anyway) " CALL MUMPS_ABORT() END IF HR_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(RANK)/3.0D0 & + 4.0D0*dble(RANK)*dble(M)*dble(N) & - 2.0D0*dble((M+N))*dble(RANK)*dble(RANK) IF (RANK.LE.MAXRANK) THEN CALL SYSTEM_CLOCK(T1) DO JJ=1, N R(1:MIN(RANK,JJ),JPVT(JJ)) = & BLOCK(1:MIN(RANK,JJ),JJ) IF(JJ.LT.RANK) R(MIN(RANK,JJ)+1: & RANK,JPVT(JJ))= ZERO END DO CALL cungqr(M, RANK, RANK, & BLOCK(1,1), MAXI_CLUSTER, & TAU(1), WORK(1), LWORK, INFO) CALL cgemm('T', 'T', N, M, RANK, ONE , & R , MAXI_CLUSTER, & BLOCK(1,1) , MAXI_CLUSTER, & ZERO, A(POSELT_BLOCK), NFRONT) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) BUILDQ_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(M) & - dble(RANK)*dble(RANK)*dble(RANK) & CB_DEMOTE_COST = CB_DEMOTE_COST + & (HR_COST+BUILDQ_COST) CB_PROMOTE_COST = CB_PROMOTE_COST + & 2.0D0*dble(RANK)*dble(M)*dble(N) FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & (M-RANK)*(N-RANK)-RANK*RANK ELSE CB_DEMOTE_COST = CB_DEMOTE_COST + HR_COST END IF END DO END DO deallocate(R) CALL STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS) CALL UPDATE_FLOP_STATS_CB_DEMOTE(CB_DEMOTE_COST, NIV) CALL UPDATE_FLOP_STATS_CB_PROMOTE(CB_PROMOTE_COST, NIV) CALL UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME) CALL UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME) END SUBROUTINE CMUMPS_FAKE_COMPRESS_CB SUBROUTINE CMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, K473, BLR_PANEL, CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & K470, KEEP8, K480, & 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, CURRENT_BLR, NIV INTEGER, intent(out) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) COMPLEX, intent(inout) :: A(LA) REAL, TARGET, DIMENSION(:) :: RWORK COMPLEX, TARGET, DIMENSION(:,:) :: BLOCK COMPLEX, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER, POINTER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, K470 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 IF (K470.EQ.1) THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE M = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF 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 = 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 (DIR .eq. 'V') THEN M = BEGS_BLR(IP+1)-BEGS_BLR(IP) POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE IF (K470.EQ.1) THEN M = BEGS_BLR(IP+1)-BEGS_BLR(IP) ELSE N = BEGS_BLR(IP+1)-BEGS_BLR(IP) ENDIF POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) END IF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF IF (K470.NE.1.OR.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, 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, RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE BLR_PANEL(IP-CURRENT_BLR)%Q = ZERO DO I=1,RANK BLR_PANEL(IP-CURRENT_BLR)%Q(I,I) = ONE END DO CALL cunmqr & ('L', 'N', M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), & M, WORK_THR(1), LWORK, INFO ) IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNMQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF 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 UPDATE_FLOP_STATS_DEMOTE( & BLR_PANEL(IP-CURRENT_BLR), NIV) END IF ELSE IF (K470.NE.1.OR.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 CALL UPDATE_FLOP_STATS_DEMOTE(BLR_PANEL(IP-CURRENT_BLR), & NIV) ENDIF BLR_PANEL(IP-CURRENT_BLR)%K = -1 END IF END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE CMUMPS_COMPRESS_PANEL END MODULE CMUMPS_FAC_LR MUMPS_5.1.2/src/dfac_mem_alloc_cb.F0000664000175000017500000001606113164366263017211 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, IFLAG, IERROR ) USE DMUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, 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 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 LOGICAL DONE 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)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF IF (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 DONE =.FALSE. IF ((IPTRLU.LT.LREQCB_WISHED).OR.(LRLU.LT.LREQCB_WISHED)) THEN IF (LRLUS.LT.LREQCB_EFF) THEN GOTO 620 ELSE 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... DMUMPS_ALLOC_CB', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF DONE = .TRUE. ENDIF ENDIF IF (IWPOSCB-IWPOS+1 .LT. LREQ) THEN IF (DONE) GOTO 600 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... DMUMPS_ALLOC_CB', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF IF (IWPOSCB-IWPOS+1 .LT. LREQ) GOTO 600 ENDIF 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+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXP+1:IWPOSCB+1+KEEP(IXSZ))=-99999 #if ! defined(NO_XXNBPR) IW(IWPOSCB+1+XXNBPR)=0 #endif ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LREQCB_EFF KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQCB_EFF KEEP8(69) = min(KEEP8(71), KEEP8(69)) #if ! defined(OLD_LOAD_MECHANISM) CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #else #if defined (CHECK_COHERENCE) CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #else CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #endif #endif RETURN 600 IFLAG = -8 IERROR = LREQ RETURN 620 IFLAG = -9 CALL MUMPS_SET_IERROR(LREQCB_EFF - LRLUS, IERROR) RETURN END SUBROUTINE DMUMPS_ALLOC_CB MUMPS_5.1.2/src/ssol_driver.F0000664000175000017500000065515613164366266016214 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_SOLVE_DRIVER(id) USE SMUMPS_STRUC_DEF USE MUMPS_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 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,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK 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 MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL 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(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSCOMP INTEGER :: PERM_PIV_LIST(max(id%KEEP(112),1)) INTEGER :: MAP_PIVNUL_LIST(max(id%KEEP(112),1)) 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_PIV_LIST permuted array of pivots C MAP_PIVNUL_LIST: mapping of permuted list 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(:) 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_IN_RHSCOMP_F, & NB_FS_IN_RHSCOMP_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV 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.0 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 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 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_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 WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE 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) IS_INIT_OOC_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)) 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. 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_IN_RHSCOMP_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_IN_RHSCOMP_F = NB_FS_IN_RHSCOMP_TOT 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 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 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 in fact effectively C -- 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 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 WRITE(6,*) " WARNING !!! A-1 OFF and KEEP(242)= ", & KEEP(242), " is reset to zero (OFF)" C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder ELSE KEEP(242) = 0 ! no permutation ENDIF 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 id%KEEP(243)=0 id%KEEP(495)=0 IF (id%KEEP(235) .EQ. 1) THEN IF (id%KEEP(497).EQ.-1) 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 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(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 ISOL_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) WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' 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) WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' 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) WRITE(MPG,'(A)') & ' ERROR: id%NRHS not allowed to change when ICNTL(32)=1' 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) WRITE(MPG,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' 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) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE INFO(2) = 20 ! ICNTL(20) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: sparse RHS incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS 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 ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 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),MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 IF (KEEP(111).eq.-1.AND.id%NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=id%NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. id%NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=id%NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN C Ignore sparse RHS in case we compute C vectors of the null space (KEEP(111)).NE.0.) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! icntl(30) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ELSE IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' INFO(2) = 20 ! inclt(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 END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21==1) THEN IF ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) 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 (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, LSCAL ) 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((J-1)*id%LRHS + I) =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 ) & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30) 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 MUMPS_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 #if defined(RHSCOMP_BYROWS) C In case of row storage with reduced right hand side, we C do not take into account empty columns during forward. C Therefore NRHS_NONEMPTY will simply be set to id%NRHS & .AND. KEEP(221) .NE. 1 #endif & ) 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))), & id%NSLAVES ) 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))), & id%NSLAVES ) 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 C Avoid to have overflows in NFRONT * NBRHS C 32-bit integer compuitations. C Should be hopefully large-enough for a while. IF(huge(NBRHS)/id%KEEP(133).LT.NBRHS) THEN IF (PROKG) WRITE(MPG,'(A,I6,A)')'Warning: NBRHS = ',NBRHS, & ' might be too large.' NBRHS = huge(NBRHS)/id%KEEP(133)-1 ! -1 to avoid rounding pbs IF (PROKG) WRITE(MPG,'(A,I6)')'NBRHS reset to ',NBRHS END IF 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 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 (id%MYID.EQ.MASTER) THEN IF ( PROKG ) THEN WRITE( MPG, 150 ) & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30) 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).OR.(KEEP(237).NE.0).OR. & (KEEP(252).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)') & ' WARNING: Incompatible features: null space basis ', & ' 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)') & ' 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)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' 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) & WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' INFO(1) = -13 INFO(2) = id%N*NBRHS GOTO 111 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 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(111),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_SOLVE = ( 4 + KEEP(133) ) * KEEP(34) + & KEEP(133) * NBRHS * KEEP(35) & + 16 * KEEP(34) ! for request id, pointer to next + safety C -------------------------------------- C Compute an upperbound of message size C for SMUMPS_GATHER_SOLUTION C -------------------------------------- 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) 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 MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for SMUMPS_GATHER_SOLUTION id%LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) id%LBUFR_BYTES = max(id%LBUFR_BYTES,TSIZE) id%LBUFR = ( id%LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) IF ( associated (id%BUFR) ) THEN NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) ENDIF ALLOCATE (id%BUFR(id%LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) & WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' INFO(1) = -13 INFO(2) = id%LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(id%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) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C CALL MPI_BCAST(KEEP(497),1,MPI_INTEGER,MASTER, & id%COMM,IERR) 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) & WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on a slave' 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 = 3 * KEEP(28) + 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) 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 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 IF ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) 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 solution C ------------------------------------- IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN C In case of scaling we will need to scale C back the RHS. 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 40 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data%SCALING=>id%ROWSCA ENDIF IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%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 40 ENDIF NB_BYTES = NB_BYTES + int(id%KEEP(89),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF 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, LSCAL ) 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 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 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 CALL MUMPS_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 MUMPS_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 C Phase 1 : SMUMPS_PERMUTE_RHS_NS C local permutations to minimize sequential disk access C with chunck of size KEEP(84)/NSLAVES C Phase 2 : SMUMPS_SOL_APPLY_PARPERM C parallel redistribution to exploit // disk access feature IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C Phase 1 to be called on each proc 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) THEN IF ( KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ELSE 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 MUMPS_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(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 / NS ENDIF ! End 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 defined(RHSCOMP_BYROWS) C In case RHSCOMP is stored by rows, we need to ensure C that the blocks during forward and backward are the C same. For that, a simple and safe solution consists in C avoiding skipping empty columns during the forward step. IF (KEEP(221).NE.1) THEN #endif 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((PERM_RHS(JBEG_RHS) -1)*LD_RHS+I) & = 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((JBEG_RHS -1)*LD_RHS + I) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN C Reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR #if defined(RHSCOMP_BYROWS) ENDIF C In that case we will have NB_RHSSKIPPED=0 C and we have JBEG_RHS = JEND_RHS+1 IF (KEEP(221).EQ.1) THEN IF ( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) THEN DO J=JBEG_RHS, JBEG_RHS + NBRHS_EFF -1 DO I=1, id%SIZE_SCHUR id%REDRHS((J-1)*LD_REDRHS + I) = ZERO ENDDO ENDDO ENDIF ENDIF #endif 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 #if defined(RHSCOMP_BYROWS) C In case of forward-only, we do not skip empty RHS. C This would cause problems during the backward phase: since C each block of RHSCOMP has a row-major storage and inside C each block, data is congiguous, blocks must be the same C during forward and during backward. Hence NB_RHSSKIPPED C will be 0. C & .OR. KEEP(221) .EQ. 1 #endif & ) 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 defined(RHSCOMP_BYROWS) IF (NZ_THIS_BLOCK .eq. 0) THEN C Skip block, C set REDRHS, RHSCOMP will be set later IF (KEEP(221).EQ.1) THEN DO J=JBEG_RHS, JBEG_RHS+ NBRHS_EFF -1 DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDDO ELSE WRITE(*,*) "Internal error 15 is sol_driver" CALL MUMPS_ABORT() ENDIF ENDIF #else IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF #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).NE.0) ) 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 ========================================================== 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).EQ.0 .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 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_IN_RHSCOMP_TOT ) NB_FS_IN_RHSCOMP_F = NB_FS_IN_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_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT, & UNS_PERM_INV, size(UNS_PERM_INV) ! size 1 if not used & ) ENDIF ENDIF ! BUILD_POSINRHSCOMP=.TRUE. 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 #if defined(RHSCOMP_BYROWS) C Stored by rows but only inside each C block. We keep IBEG_RHSCOMP unchanged C for locality since both SCATTER_RHS and C GATHER_SOLUTION will be done block-by-block? IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 #else IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 #endif 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 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 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 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 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(PERM_RHS(I)) * & 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(PERM_RHS(I))+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+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 IF(id%MYID.EQ.MASTER) 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_IN_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 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, * - to build Ej and store it in RHSCOMP K=1 ! Column index in RHSCOMP id%RHSCOMP(1:NBRHS_EFF*LD_RHSCOMP) = 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_IN_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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP((IPOSRHSCOMP-1)*NBRHS_EFF+K) = & RHS_SPARSE_COPY(IPOS) #else id%RHSCOMP((K-1)*LD_RHSCOMP+IPOSRHSCOMP) = & RHS_SPARSE_COPY(IPOS) #endif 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 #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error 17 is sol driver" CALL MUMPS_ABORT() #else DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, LD_RHSCOMP id%RHSCOMP((K-1)*LD_RHSCOMP + I) = ZERO ENDDO ENDDO #endif ENDIF #if defined(RHSCOMP_BYROWS) IF (I_AM_SLAVE) THEN DO I=1, NBENT_RHSCOMP DO K = 1, NBCOL_INBLOC C NBCOL_INBLOC is equal to NBRHS_EFF in this case id%RHSCOMP(IBEG_RHSCOMP+ & int(I-1,8)*int(NBRHS_EFF,8)+int(K-1,8))=ZERO ENDDO ENDDO ENDIF C Test below must be done also on non-working host !! IF (NZ_THIS_BLOCK .EQ. 0 .AND. KEEP(221).EQ.1) THEN C Skip the rest, go to next block. GOTO 1000 ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = IBEG_RHSCOMP + int(K-1,8) #else 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 #endif 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_IN_RHSCOMP_TOT IF ( (IPOSRHSCOMP.LE.NB_FS_IN_RHSCOMP_TOT) & .AND.(IPOSRHSCOMP.GT.0) ) THEN C ! I is fully summed var mapped on my proc #if defined(RHSCOMP_BYROWS) id%RHSCOMP(KDEC+(IPOSRHSCOMP-1)*NBRHS_EFF)= & id%RHSCOMP(KDEC+(IPOSRHSCOMP-1)*NBRHS_EFF) + & RHS_SPARSE_COPY(IZ) #else id%RHSCOMP(KDEC+IPOSRHSCOMP)= & id%RHSCOMP(KDEC+IPOSRHSCOMP) + & RHS_SPARSE_COPY(IZ) #endif 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 IF (INTERLEAVE_PAR .AND.(id%NSLAVES .GT. 1) ) THEN IRHS_SPARSE_COPY(II) = PERM_PIV_LIST(I) ELSE IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) ENDIF 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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP(1:NBRHS_EFF*LD_RHSCOMP)=ZERO #else 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 #endif 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 IF ((KEEP(235).NE.0) .AND. INTERLEAVE_PAR) THEN C When the PIVNUL_LIST has been permuted (in PERM_PIV_LIST) C then to exploit sparsity RHSCOMP need be initialized with c some care; taking into acount the processor localisation C of the indices of the null pivots. DO I=IBEG_GLOB_DEF,IEND_GLOB_DEF C Local processor is concerned by I-th column of C global right-hand side. IF (id%MYID_NODES .EQ. MAP_PIVNUL_LIST(I) ) THEN JJ= id%POSINRHSCOMP_ROW(PERM_PIV_LIST(I)) IF (JJ.GT.LD_RHSCOMP) THEN WRITE(6,*) ' Internal Error 10 JJ, LD_RHSCOMP=', & JJ, LD_RHSCOMP ENDIF IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN C unsymmetric : always set to fixation used during facto C because during factorization we aimed at preserving the C sign of the diagonal element, sign here may be different C from sign of corresponding diagonal element (not critical) #if defined(RHSCOMP_BYROWS) id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)* int(NBRHS_EFF,8)) = #else id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8)) = #endif & abs(id%DKEEP(2)) ELSE #if defined(RHSCOMP_BYROWS) id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8) *int(NBRHS_EFF,8)) = ONE #else id%RHSCOMP(IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8)) = ONE #endif ENDIF ENDIF ENDIF ENDDO ELSE 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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)*int(NBRHS_EFF,8) ) = #else id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8) ) = #endif & id%DKEEP(2) ELSE ! Symmetric: always set to one #if defined(RHSCOMP_BYROWS) id%RHSCOMP( IBEG_RHSCOMP+int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)*int(NBRHS_EFF,8) )= #else id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8)+ & int(JJ-1,8) )= #endif & ONE ENDIF ENDIF ENDDO ENDIF ! exploit sparsity 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 IF(id%MYID.EQ.MASTER) THEN TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 ENDIF 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, & id%BUFR(1), id%LBUFR, id%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, & id%BUFR(1), id%LBUFR, id%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) C size 1 if not used & , UNS_PERM_INV, NB_FS_IN_RHSCOMP_F, NB_FS_IN_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 TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) 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 #if defined(RHSCOMP_BYROWS) LCWORK = NBRHS_EFF #else LCWORK = max(max(KEEP(247),KEEP(246)),1) #endif ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) 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 ) IF(id%MYID.EQ.MASTER) 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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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_IN_RHSCOMP_TOT & ) ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 ENDIF 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 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 COLSIZE = id%IRHS_PTR(PERM_RHS(J)+1) - & id%IRHS_PTR(PERM_RHS(J)) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 c IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PERM_RHS(J)), & id%IRHS_PTR(PERM_RHS(J)+1)-1 I = id%IRHS_SPARSE (IZ) DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN WRITE(6,*) " Internal Error 13 in solution ", & " driver, gather " CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ELSE ! Not (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 COLSIZE = id%IRHS_PTR(J+1) - id%IRHS_PTR(J) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 c IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(J), id%IRHS_PTR(J+1) - 1 I = id%IRHS_SPARSE (IZ) DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN WRITE(6,*) " Internal Error 14 in solution", & " driver, gather " CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR 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, 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 ) 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 ) 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 #if defined(RHSCOMP_BYROWS) 1000 CONTINUE #endif 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((PERM_RHS(JBEG_NEW) -1)*LD_RHS+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((JBEG_NEW -1)*LD_RHS + 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((PERM_RHS(JBEG_NEW) -1)*id%LSOL_LOC+I) & = 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((JBEG_NEW -1)*LD_REDRHS + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN #if defined(RHSCOMP_BYROWS) DO I=1,NBENT_RHSCOMP JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) id%RHSCOMP(JBEG_NEW + (I-1)*NBRHS_EFF) = ZERO JBEG_NEW = JBEG_NEW +1 ENDDO ENDDO #else JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSCOMP id%RHSCOMP((JBEG_NEW -1)*LD_RHSCOMP + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO #endif 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 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 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) IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Global statistics" WRITE( MPG, 434 ) id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) WRITE( MPG, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(116) ! non-zero if gather WRITE( MPG, 431 ) id%DKEEP(122) ! Distributed solution 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(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(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 (associated(id%BUFR)) THEN NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 DEALLOCATE(id%BUFR) NULLIFY(id%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%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%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 RHS (dist.sol)=',F15.6) 150 FORMAT(/' 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) 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_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_IN_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, id%BUFR(1), id%LBUFR, & id%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, C Case of special root node & 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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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.1.2/src/cmumps_comm_buffer.F0000664000175000017500000035675713164366265017535 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 :: 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 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 ) 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) 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 INCLUDE 'mpif.h' INTEGER :: IERR 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) 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 ) CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), IERR ) 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, COMPRESSCB, & 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 COMPRESSCB INCLUDE 'mpif.h' 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) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR) 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 (COMPRESSCB) 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 (COMPRESSCB) 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 ) 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 ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (COMPRESSCB) 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 ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (COMPRESSCB) 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 ) 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 ) 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 ) 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 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 ) 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 ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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 ) ) # if defined(RHSCOMP_BYROWS) COMPLEX RHSCOMP(NRHS,LRHSCOMP) # else COMPLEX RHSCOMP(LRHSCOMP,NRHS) # endif INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' 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 ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_COMPLEX, & COMM, SIZE2, IERR ) 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 ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) IF (NODE2.EQ.0.AND.KEEP(350).NE.0) THEN DO K=1, NRHS_B #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in CMUMPS_BUF_SEND_VCB" CALL MUMPS_ABORT() #else IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1), NPIV, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) 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 ) ENDIF #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 ) 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 ) 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 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 ) 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 ) KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR ) 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 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 ) 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 :: 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 ) 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, & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , LRSTATUS &) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER INODE INTEGER NLIG, NCOL, NASS, NSLAVES 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 SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE_INT = ( 7 + NLIG + NCOL + NSLAVES + 1 ) SIZE_INT = SIZE_INT + 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 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 ) 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 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 ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR) 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 ) 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 ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & COMPRESSCB, KEEP253_LOC ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC INTEGER IPERE, ISON, NBROW 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( * ) LOGICAL DESC_IN_LU, COMPRESSCB 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 NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX INTEGER NBROWS_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: SIZFR, ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, 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) PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' REAL ZERO PARAMETER (ZERO = 0.0E0) 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) CALL MUMPS_GETI8( SIZFR, IW_CBSON( 1 + XXR ) ) 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, PS1, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_REAL, & COMM, SIZE1, IERR ) ENDIF SIZE1 = SIZE1+PS1 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 CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR ) 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, & min( NBROWS_PACKET, NBROW - NBROWS_ALREADY_SENT)) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET * LROW ELSE SIZE_REALS = ( LROW + PERM(1) + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET + ( NBROWS_PACKET * ( NBROWS_PACKET + 1) ) / 2 MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET CALL MPI_PACK_SIZE( SIZE_REALS, MPI_COMPLEX, & COMM, SIZE2, IERR) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR) IF (SIZE2 + SIZE3 .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 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) & 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 ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) ENDDO 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 ) ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( COMPRESSCB ) 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 ( COMPRESSCB ) 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 ) ENDDO 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 ) IF(NFS4FATHER .GT. 0) THEN 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 (COMPRESSCB) 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 (COMPRESSCB) 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 = SIZFR - (SHIFTCB_SON - & int(PS1-1,8) * LDA_SON8) LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC .NE. 0 ) THEN CALL CMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC, & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 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 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 ) 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 ) 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, & SEND_LR, 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) :: SEND_LR INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER :: SEND_LR_INT INTEGER, intent(inout) :: IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' 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 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 ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR ) 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 ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF END IF SIZE2 = 0 CALL MPI_PACK_SIZE(4, MPI_INTEGER, COMM, SIZE3, IERR) SIZE2=SIZE2+SIZE3 IF ( KEEP(50).NE.0 ) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, COMM, SIZE3, IERR) SIZE2=SIZE2+SIZE3 ENDIF IF ((NPIV.GT.0) & ) THEN IF (.NOT. SEND_LR) THEN CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_COMPLEX, & COMM, SIZE3, IERR ) SIZE2 = SIZE2+SIZE3 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), MPI_COMPLEX, & COMM, SIZE3, IERR ) 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 ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) 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 ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( LASTBL .or. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) THEN SEND_LR_INT=1 ELSE SEND_LR_INT=0 ENDIF CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) ENDIF IF (SEND_LR) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) END DO CALL MUMPS_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 ) END DO ENDIF ENDIF CALL MPI_PACK( LRELAY_INFO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( LRELAY_INFO.GT.0) & CALL MPI_PACK( RELAY_INFO, LRELAY_INFO, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) 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 ) 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, & SEND_LR, 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) :: SEND_LR 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) INTEGER :: SEND_LR_INT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' 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 ) SIZE2 = 0 CALL MPI_PACK_SIZE(2, MPI_INTEGER, COMM, SSLR, IERR) SIZE2=SIZE2+SSLR IF (.NOT. SEND_LR) THEN CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_COMPLEX, & COMM, SSLR, IERR ) 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 ) 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 ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) THEN SEND_LR_INT=1 ELSE SEND_LR_INT=0 ENDIF CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) 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 ) 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 ) 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, DIMENSION(:) :: RG2L_ROW INTEGER, DIMENSION(:) :: RG2L_COL 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 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 ) 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) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_COMPLEX, COMM, & SIZE_TMP, IERR) 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 ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_COMPLEX, & COMM, SIZE2, IERR ) 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 ! defined(DBG_SMB3) 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 #endif ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR ) 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 ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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.1.2/src/sfac_process_rtnelind.F0000664000175000017500000001061613164366262020210 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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,ND ) USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' 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) 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)), SLAVEF) 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, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, 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(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.1.2/src/dooc_panel_piv.F0000664000175000017500000002757613164366266016641 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/mumps_common.h0000664000175000017500000000501113164366240016377 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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(); #endif /* MUMPS_COMMON_H */ MUMPS_5.1.2/src/csol_matvec.F0000664000175000017500000002365513164366266016151 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(out) :: 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.1.2/src/zana_mtrans.F0000664000175000017500000007675413164366266016177 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zfac_root_parallel.F0000664000175000017500000001517413164366265017510 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_FACTO_ROOT( 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) USE ZMUMPS_LR_STATS, ONLY: UPDATE_FLOPS_STATS_ROOT IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' TYPE ( ZMUMPS_ROOT_STRUC ) :: root 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 IOLDPS INTEGER(8) :: IAPOS 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 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 UPDATE_FLOPS_STATS_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 UPDATE_FLOPS_STATS_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,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 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, DKEEP(6), KEEP(259), & 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.1.2/src/dfac_process_contrib_type1.F0000664000175000017500000001055013164366263021132 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) 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(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 COMPRESSCB 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) COMPRESSCB = (FLCONT.LT.0) IF (COMPRESSCB) 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) IF (IPTRLU.LT.0_8) WRITE(*,*) 'before alloc_cb:IPTRLU = ',IPTRLU CALL DMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, IFLAG, IERROR & ) IF (IPTRLU.LT.0_8) WRITE(*,*) 'after alloc_cb:IPTRLU = ',IPTRLU IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (COMPRESSCB) 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 (COMPRESSCB) 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 IF ( LREQCB .ne. 0_8 ) THEN IPOS_NODE = PAMASTER(STEP(FINODE))-1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + 1_8 + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR) END IF 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.1.2/src/dfac_asm.F0000664000175000017500000005704013164366263015377 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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(8) :: POSELT 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)) POSELT = PTRAST(STEP(INODE)) 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, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), & RHS_MUMPS) 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) IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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 INCLUDE 'mumps_headers.h' INTRINSIC real IOLDPS = PTRIST(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) 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(APOS+int(J-1,8)) = A( 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(K8) = A(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(APOS:APOS+int(NBCOLS-IDIAG-1,8))= & A(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(K8) = A(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 & ) 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 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.300 !$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)) & A(JJ2) = VALSON(JJ1) 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) 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) 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 :: 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)) A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = ZERO NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) 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 MUMPS_5.1.2/src/dmumps_lr_data_m.F0000664000175000017500000005411613164366264017153 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_PANEL_LORU, & DMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & DMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & DMUMPS_BLR_RETRIEVE_PANEL_L, & DMUMPS_BLR_RETRIEVE_PANEL_LORU, & DMUMPS_BLR_DEC_AND_TRYFREE_L, & DMUMPS_BLR_TRY_FREE_PANEL, & DMUMPS_BLR_FREE_ALL_PANELS, & DMUMPS_BLR_FREE_PANEL TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(lrb_type), pointer :: LRB_PANEL(:) END TYPE blr_panel_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 INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333) 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) 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) ENDDO RETURN END SUBROUTINE DMUMPS_BLR_INIT_MODULE SUBROUTINE DMUMPS_BLR_END_MODULE(INFO1, KEEP8, IS_FACTOR) INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: I, ILOOP IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF ILOOP=0 DO I=1, size(BLR_ARRAY) ILOOP= ILOOP+1 IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U)) THEN IF (INFO1 .GE.0) THEN WRITE(*,*) "Internal error 2 in MUMPS_BLR_END_MODULE ", & " IWHANDLER=", I CALL MUMPS_ABORT() ELSE CALL DMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, IS_FACTOR) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE DMUMPS_BLR_END_MODULE SUBROUTINE DMUMPS_BLR_INIT_FRONT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error in DMUMPS_BLR_INIT_FRONT ", & NB_PANELS ENDIF CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) 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 RETURN 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) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) ELSE ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (associated(BEGS_BLR_COL)) THEN INFO(2)=size(BEGS_BLR_L)+size(BEGS_BLR_COL) ELSE INFO(2)=size(BEGS_BLR_L) ENDIF RETURN ENDIF ELSE IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(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_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN INFO(2)=NB_PANELS+size(BEGS_BLR_L)+size(BEGS_BLR_COL) ELSE IF (IsSYM) THEN INFO(2)=NB_PANELS+size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+size(BEGS_BLR_L) ENDIF RETURN 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 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 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_INIT_FRONT SUBROUTINE DMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, & KEEP8, IS_FACTOR) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) THEN RETURN 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) THEN WRITE(*,*) " Internal Error 2 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, IS_FACTOR) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF ENDIF ENDDO NULLIFY(THEPANEL%LRB_PANEL) 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) THEN WRITE(*,*) " Internal Error 2 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, IS_FACTOR) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF ENDIF ENDDO NULLIFY(THEPANEL%LRB_PANEL) IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF ENDIF IF (.NOT. associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER CALL MUMPS_ABORT() ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) 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 CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) 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 ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 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_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_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_PANEL_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_RETRIEVE_PANEL_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_RETRIEVE_PANEL_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_RETRIEVE_PANEL_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_RETRIEVE_PANEL_L 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", & "IPANEL=", IPANEL 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", & "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_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF 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 ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 2 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(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_U(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT - 1 ENDIF RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE DMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8, IS_FACTOR) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR 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, IS_FACTOR) RETURN END SUBROUTINE DMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE DMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE DMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE DMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO 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 (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_BLR_FREE_ALL_PANELS SUBROUTINE DMUMPS_BLR_FREE_PANEL( IWHANDLER, LORU, IPANEL, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: LORU INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF (LORU.EQ.0.or.LORU.EQ.1) THEN IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ELSE 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE DMUMPS_BLR_FREE_PANEL END MODULE DMUMPS_LR_DATA_M MUMPS_5.1.2/src/dana_lr.F0000664000175000017500000003527613164366264015252 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1)) 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)) 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 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) :: LRGROUPS(N), VLIST(NV), TRACE(N) 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 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, INTENT(INOUT) :: LRGROUPS(N) INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1)) NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO PARTPTR(1)=1 CNT = 0 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 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 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 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 INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP)) ALLOCATE(PERM(NSEP)) ALLOCATE(IPERM(NSEP)) ALLOCATE(SIZES(NPARTS)) ALLOCATE(PARTPTR(NPARTS+1)) 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)) 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 END MODULE DMUMPS_ANA_LR MUMPS_5.1.2/src/ssol_bwd.F0000664000175000017500000012175513164366263015463 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NA, LNA, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, 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 & , TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE SMUMPS_OOC USE SMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER(8), intent(in) :: LWC INTEGER N,LIW,LIWW,LPOOL,LNA INTEGER SLAVEF,MYLEAF,COMM,MYID INTEGER LPANEL_POS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NA(LNA),NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(40), INFO(40) 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) #if defined(RHSCOMP_BYROWS) REAL RHSCOMP(NRHS,LRHSCOMP) #else REAL RHSCOMP(LRHSCOMP,NRHS) #endif INTEGER(8), intent(in) :: LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) 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 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INTEGER POSIWCB,K INTEGER(8) :: APOS, IST INTEGER(8) :: IFR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB,NBFINF INTEGER NBLEAF,INODE,NBROOT,NROOT,NBFILS INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER III,IIPOOL,MYLEAFE INTEGER NSLAVES INTEGER JBDEB, JBFIN, NRHS_B REAL ALPHA,ONE,ZERO PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) LOGICAL BLOQ,DEBUT INTEGER PROCDEST, DEST INTEGER POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL, & IPOSINRHSCOMP_TMP INTEGER DUMMY(1) INTEGER(8) :: POSWCB, PLEFTW, PTWCB INTEGER Offset, EffectiveSize, ISLAVE, FirstIndex LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INCLUDE 'mumps_headers.h' LOGICAL BLOCK_SEQUENCE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL Exploit_Sparsity, AM1 DOUBLE PRECISION :: TIME_TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok 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 LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER MUMPS_TYPENODE EXTERNAL sgemv, strsv, strsm, sgemm, & MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR 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 NROOT = 0 NBLEAF = NA(1) NBROOT = NA(2) DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) .EQ. MYID) THEN NROOT = NROOT + 1 IPOOL(NROOT) = INODE ENDIF END DO III = 1 IIPOOL = NROOT + 1 BLOCK_SEQUENCE = .FALSE. Exploit_Sparsity = .FALSE. AM1 = .FALSE. IF (KEEP(235).NE.0) Exploit_Sparsity = .TRUE. IF (KEEP(237).NE.0) AM1 = .TRUE. NO_CHILDREN = .FALSE. IF (Exploit_Sparsity .OR. AM1) MYLEAF = -1 IF (MYLEAF .EQ. -1) THEN MYLEAF = 0 DO I=1, NBLEAF INODE=NA(I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) .EQ. MYID) THEN MYLEAF = MYLEAF + 1 ENDIF ENDDO ENDIF MYLEAFE=MYLEAF NBFINF = SLAVEF IF (MYLEAFE .EQ. 0) THEN CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) THEN GOTO 340 ENDIF ENDIF 50 CONTINUE 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 GO TO 60 ENDIF END IF IF ( NBFINF .eq. 0 ) GOTO 340 GOTO 50 IF (MYID.EQ.0) write(6,*) "BWD: process INODE=", INODE 60 CONTINUE 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO JJ = J1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP_TMP) = RHS_ROOT(IFR+NPIV*(K-1)) #else RHSCOMP(IPOSINRHSCOMP_TMP,K) = RHS_ROOT(IFR+NPIV*(K-1)) #endif END DO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE CALL SMUMPS_SOL_CPY_FS2RHSCOMP(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) ENDIF IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 ENDIF GOTO 50 ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( AM1 ) 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 DEBUT = .TRUE. DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( AM1 ) 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)),SLAVEF) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & SLAVEF) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) GOTO 330 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF ( IERR .NE. 0 ) CALL MUMPS_ABORT() ENDIF IF = FRERE(STEP(IF)) ENDDO IF (AM1 .AND.NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 ENDIF 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 GOTO 50 END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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)) GOTO 330 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 330 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2 - KEEP(253) J = IW(JJ) IFR = IFR + 1_8 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN W(IFR+int(K-JBDEB,8)*int(NCB,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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) ELSE WRITE(*,*) "Internal error SMUMPS_SOL_S" CALL MUMPS_ABORT() END IF 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 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) GOTO 50 ENDIF 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) 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 330 ENDIF ENDIF APOS = PTRFAC(IW(IPOS)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1) 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)) GOTO 330 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) ) GOTO 330 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 330 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(350).eq.0) THEN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = ZERO ENDDO ELSE DO JJ = J1, J2 #if defined(RHSCOMP_BYROWS) W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif ENDDO ENDIF ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = ZERO ENDDO ENDIF ELSE WRITE(*,*) "Internal error SMUMPS_SOL_BWD" CALL MUMPS_ABORT() 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1_8 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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) ELSE WRITE(*,*) "Internal error SMUMPS_SOL_S" CALL MUMPS_ABORT() ENDIF 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) 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 (KEEP(350).EQ.0) THEN CALL sgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( PTWCB_PANEL+int(NBJ,8) ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ELSE IF (NCB_PANEL - NCB.NE. 0) THEN CALL sgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), & 1, ONE, & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif 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, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF ENDIF ENDIF IF (MTYPE.NE.1) THEN IF (KEEP(350).eq.0) THEN CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ELSE IF (KEEP(350).eq.0) THEN CALL strsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL strsv('L','T','N', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (KEEP(350).eq.0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(PTWCB_PANEL+int(NBJ,8)),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in SMUMPS_SOL_S" CALL MUMPS_ABORT() #else 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 ENDIF ENDIF IF (MTYPE.NE.1) THEN IF (KEEP(350).eq.0) THEN CALL strsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in SMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL strsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF ELSE IF (KEEP(350).eq.0) THEN CALL strsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in SMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL strsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ENDIF IF (KEEP(201).EQ.0.OR.KEEP(201).EQ.2)THEN 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 IF (KEEP(350).EQ.0) THEN CALL sgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & W(PTWCB), 1 ) ELSE CALL sgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL sgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & W(PTWCB), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in SMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL sgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #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 IF (KEEP(350).EQ.0) THEN CALL sgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB+int(NPIV,8) ), & 1, ONE, & W(PTWCB), 1 ) ELSE CALL sgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL sgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, W(PTWCB),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in SMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL sgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB),LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL strsv('L', 'T', 'N', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL strsv('L', 'T', 'N', NPIV, A(APOS), LIELL, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL strsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), & LIELL, W(PTWCB), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in SMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL strsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), & LIELL, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE LDAJ=NPIV ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL strsv('U','N','U', NPIV, A(APOS), LDAJ, & W(PTWCB), 1) ELSE CALL strsv('U','N','U', NPIV, A(APOS), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL strsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), & LDAJ,W(PTWCB),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in SMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL strsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), & LDAJ, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif END IF 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO 150 I = 1, NPIV DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP_TMP) = W(PTWCB+I-1+(K-JBDEB)*LIELL) #else RHSCOMP(IPOSINRHSCOMP_TMP, K) = W(PTWCB+I-1+(K-JBDEB)*LIELL) #endif ENDDO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 150 CONTINUE ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*)"Internal error in SMUMPS_SOL_S" CALL MUMPS_ABORT() ENDIF 160 CONTINUE IF (KEEP(201).GT.0) 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 330 ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 ENDIF GOTO 50 ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF (AM1) 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 ( AM1 ) 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 (AM1 .AND. NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 ENDIF ENDIF ELSE DEBUT = .TRUE. DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( AM1 ) 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)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),SLAVEF) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 330 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF (AM1 .AND. NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 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 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 GOTO 50 330 CONTINUE CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, & SLAVEF, KEEP) 340 CONTINUE CALL SMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE SMUMPS_SOL_S MUMPS_5.1.2/src/zana_aux_par.F0000664000175000017500000027547613164366265016333 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, POINTER :: WORK1(:), WORK2(:), & 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 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 CALL ZMUMPS_DO_PAR_ORD(id, ord, WORK2) 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) 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%KEEP(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 CALL ZMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), & NFSIZ(1), 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 CALL ZMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), NFSIZ(1), & 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, WORKERS #if defined(parmetis) || defined(parmetis3) INTEGER :: I, COLOR, BASE 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, POINTER :: 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, POINTER :: 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(MUMPS_GETSIZE(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, POINTER :: 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(MUMPS_GETSIZE(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 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)) 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) 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, POINTER :: 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(MUMPS_GETSIZE(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 = .TRUE. 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 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) 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=1, TOPNODES(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 INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR)) 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 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)) 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)) 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 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 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)) 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)) 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 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1)) 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) 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 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)) ALLOCATE(RCVBUF(2*BUFSIZE)) ALLOCATE(PENDING(NPROCS), CPNT(NPROCS)) ALLOCATE(REQ(NPROCS)) 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)) 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 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_COPY_INT_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_COPY_INT_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_COPY_INT_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_COPY_INT_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_COPY_INT_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_COPY_INT_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_COPY_INT_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_COPY_INT_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_COPY_INT_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_COPY_INT_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_COPY_INT_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_COPY_INT_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.1.2/src/smumps_iXamax.F0000664000175000017500000000104213164366263016464 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C INTEGER FUNCTION SMUMPS_IXAMAX(N,X,INCX) REAL X(*) INTEGER INCX,N INTEGER isamax SMUMPS_IXAMAX = isamax(N,X,INCX) RETURN END FUNCTION SMUMPS_IXAMAX MUMPS_5.1.2/src/sfac_sol_pool.F0000664000175000017500000004543313164366262016466 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & K28, K76, K80, K47, STEP, INODE) USE SMUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47 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)), & SLAVEF)) & ) 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)), & SLAVEF) ) 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 defined(NOT_ATM_POOL_SPECIAL) J=NBTOP #else 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 #endif DO I=J,1,-1 #if defined(NOT_ATM_POOL_SPECIAL) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE = POOL(LPOOL-2-I) - N ELSE NODE = POOL(LPOOL-2-I) ENDIF #else NODE=POOL(LPOOL-2-I) #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 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ELSEIF(KEEP(81).EQ.3)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) 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)), SLAVEF) ) 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)), & SLAVEF)) 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)), & SLAVEF) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & SLAVEF)) 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.0).AND.(INODE.LE.N))THEN #endif 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 #if ! defined(NOT_ATM_POOL_SPECIAL) 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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GT.0).AND.(INODE.LE.N))THEN #endif 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) #if ! defined(NOT_ATM_POOL_SPECIAL) ELSE ENDIF #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 ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GT.0).AND.(INODE.LT.N))THEN #endif SBTR_FLAG=(NBINSUBTREE.NE.0) #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #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)), & SLAVEF))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.1.2/src/ana_set_ordering.F0000664000175000017500000000504213164366241017134 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE MUMPS_SET_ORDERING(N, SYM, NPROCS, IORD, & symmetry, NBQD, AvgDens, & PROK, MP) IMPLICIT NONE INTEGER, intent(in) :: N, NPROCS, SYM INTEGER, intent(in) :: symmetry, 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.1.2/src/ssol_fwd_aux.F0000664000175000017500000013752613164366263016347 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, III, 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_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, III, LEAF, NBFIN, LRHSCOMP INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 40 ), 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 ) #if defined(RHSCOMP_BYROWS) REAL RHSCOMP( NRHS, LRHSCOMP ) #else REAL RHSCOMP( LRHSCOMP, NRHS ) #endif 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 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 DOUBLE PRECISION :: TIME_TMP 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 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'Internal error 41r2 : Pool is too small.' CALL MUMPS_ABORT() END IF END IF 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))) #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) = & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + & WCB(PLEFTWCB+I-1) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) = & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) #endif ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF IF ( PTRICB(STEP(FINODE)) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'Internal error 41r2 : Pool is too small.' CALL MUMPS_ABORT() END IF ENDIF END IF 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 + (NPIV + NCV) * NRHS_B 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 IF (KEEP(201).GT.0) 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 APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201).EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE #endif CALL sgemm( 'N', 'N', NCV, NRHS_B, NPIV, ALPHA, & A(APOS), NCV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE #endif CALL sgemm( 'T', 'N', NCV, NRHS_B, NPIV, ALPHA, & A(APOS), NPIV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF IF (KEEP(201).GT.0) 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 - NPIV * NRHS_B PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & SLAVEF ) 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 IF (KEEP(350).EQ.0) THEN DO I = 1, NCV JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) DO K=1, NRHS_B #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + & WCB(PTRY+I-1+(K-1)*NCV) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PTRY+I-1+(K-1)*NCV) #endif ENDDO END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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)) #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) #endif & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF PTRICB(STEP(FINODE)) = & PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'INTERNAL Error 41r: Pool is too small.' 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, III, 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 - NCV * NRHS_B 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( INODE, & BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, III, 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, & MYROOT, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) USE SMUMPS_OOC USE SMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER INODE, LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, III, LEAF, NBFIN INTEGER MYROOT INTEGER INFO( 40 ), 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 ) REAL RHS_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 #if defined(RHSCOMP_BYROWS) REAL RHSCOMP(NRHS, LRHSCOMP) #else REAL RHSCOMP(LRHSCOMP, NRHS) #endif REAL VALPIV, A11, A22, A12, DETPIV LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP EXTERNAL sgemv, strsv, sgemm, strsm, MUMPS_PROCNODE INTEGER MUMPS_PROCNODE REAL ALPHA,ONE,ZERO PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) DOUBLE PRECISION TIME_TMP INTEGER JBDEB, JBFIN, NRHS_B INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, & IERR, & LIELL, JJ, & NELIM INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: POSWCB1, POSWCB2 INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, & JFIN, NBJ, NUPDATE_PANEL, & NBK, NBK_ini, TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB INTEGER LDAJ, LDAJ_ini, LDAJ_FIRST_PANEL INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY( 1 ) DUMMY(1)=1 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 (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) 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+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 ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSCOMP_TMP = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.0) THEN DO JJ = J1, J3 IFR8 = IFR8 + 1_8 DO K=JBDEB,JBFIN RHS_ROOT(IFR8+int(NPIV,8)*int(K-1,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif END DO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP+JJ-J1) #else & RHSCOMP(IPOSINRHSCOMP_TMP+JJ-J1,K) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error in SOLVE_NODE for Root node' CALL MUMPS_ABORT() END IF MYROOT = MYROOT - 1 IF ( MYROOT .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 GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF (KEEP(201).EQ.1) 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 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 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)) GO TO 260 END IF IF (KEEP(201).EQ.1) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV DO K=JBDEB, JBFIN IFR8 = PPIV_COURANT+int(K-JBDEB,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 #if defined(RHSCOMP_BYROWS) WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) #endif IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDDO IF (NCB.GT.0) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) #if defined(RHSCOMP_BYROWS) WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) RHSCOMP (K,IPOSINRHSCOMP) = ZERO #else WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP (IPOSINRHSCOMP,K) = ZERO #endif ENDDO ENDIF ENDDO ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.0) THEN !$ OMP_FLAG = NRHS_B.GT.4 .AND. .FALSE. !$OMP PARALLEL DO PRIVATE(J,IFR8,K) IF(OMP_FLAG) DO 130 JJ = J1, J3 J = IW(JJ) IFR8 = IFR_ini8 + int(JJ-J1+1,8) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) WCB(IFR8+(K-JBDEB)*NPIV) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else WCB(IFR8+(K-JBDEB)*NPIV) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif END DO 130 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(JJ,IFR8) IF(OMP_FLAG) DO K=JBDEB, JBFIN IFR8 = IFR_ini8 + (K-JBDEB)*NPIV DO JJ = J1, J3 #if defined(RHSCOMP_BYROWS) WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF IFR8 = PCB_COURANT - 1_8 IF (NPIV .LT. LIELL) THEN IFR_ini8 = IFR8 IF (KEEP(350).EQ.0) THEN !$OMP PARALLEL DO PRIVATE(J,IFR8,K,IPOSINRHSCOMP) IF(OMP_FLAG) DO 140 JJ = J3 + 1, J2 J = IW(JJ) IFR8 = IFR_ini8 + (JJ-J3) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(IPOSINRHSCOMP,K) #endif #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP)=ZERO #else RHSCOMP(IPOSINRHSCOMP,K)=ZERO #endif ENDDO 140 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J2-J3)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP) IF (OMP_FLAG) DO K=JBDEB, JBFIN IFR8 = IFR_ini8+(K-JBDEB)*NCB DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) #if defined(RHSCOMP_BYROWS) WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(IPOSINRHSCOMP,K) #endif #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP)=ZERO #else RHSCOMP(IPOSINRHSCOMP,K)=ZERO #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (KEEP(201).EQ.1) 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 (KEEP(50).NE.0) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), NPIV, WCB(PPIV_COURANT), & NPIV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1) THEN CALL strsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV ) #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), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm('L','L','N','N',NPIV, NRHS_B, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV) #if defined(MUMPS_USE_BLAS2) ENDIF #endif END IF END IF 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 ( NPIV .NE. 0 .AND. NUPDATE.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), & NPIV, WCB(PPIV_COURANT), 1, ONE, & WCB(PCB_COURANT), 1) ELSE #endif CALL sgemm('T', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), & LIELL, WCB(PPIV_COURANT), 1, & ONE, WCB(PCB_COURANT), 1 ) ELSE #endif CALL sgemm('N', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF END IF IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN IF (KEEP(350).EQ.0) THEN DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + int(K-JBDEB,8)*int(LD_WCBPIV,8) #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1) = #else RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1,K) = #endif & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN #if defined(RHSCOMP_BYROWS) !$ OMP_FLAG = (NPIV.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8,K) IF (OMP_FLAG) DO I=1,NPIV IFR8 = PPIV_COURANT + I-1 DO K=JBDEB,JBFIN RHSCOMP(K,IPOSINRHSCOMP+I-1) = & WCB(IFR8+(K-JBDEB)*LD_WCBPIV) ENDDO ENDDO !$OMP END PARALLEL DO #else !$ 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 #endif ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1) THEN LDAJ = TempNROW ELSE LDAJ = NPIV ENDIF APOS1 = APOS JJ = J1 IF (KEEP(201).EQ.1) THEN NBK = 0 ENDIF IF (KEEP(350).EQ.0) THEN DO IF(JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF(IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV #else RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV #endif END DO IF (KEEP(201).EQ.1) 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) THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1) 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 DO K=JBDEB, JBFIN POSWCB1 = IFR8+int(K-JBDEB,8)*int(LD_WCBPIV,8) POSWCB2 = POSWCB1+1_8 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #endif END DO IF (KEEP(201).EQ.1) 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 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1) 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 ) #if defined(RHSCOMP_BYROWS) RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = & WCB( IFR8 ) * VALPIV #else RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV #endif IF (KEEP(201).EQ.1) 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) THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1) 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #endif IF (KEEP(201).EQ.1) 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 ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF END IF IF (KEEP(201).GT.0) 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 END IF FPERE = DAD(STEP(INODE)) IF ( FPERE .EQ. 0 ) THEN MYROOT = MYROOT - 1 PLEFTWCB = PLEFTWCB - LIELL *NRHS_B IF ( MYROOT .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 GO TO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 IF (KEEP(350).EQ.0) THEN !$ OMP_FLAG = .FALSE. !$OMP PARALLEL DO PRIVATE(K,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) DO 190 I = 1, NUPDATE IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & RHSCOMP( K, IPOSINRHSCOMP_TMP ) #else RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) #endif & + WCB(PCB_COURANT + I-1 +(K-JBDEB)*LD_WCBCB) ENDDO 190 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NUPDATE*(JBFIN-JBDEB+1) .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 IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & RHSCOMP( K, IPOSINRHSCOMP_TMP ) #else RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) #endif & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE IF ( PTRICB(STEP(INODE)) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 ENDIF END IF ELSE PTRICB(STEP( INODE )) = -1 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 ENDIF 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)), SLAVEF), & 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, III, 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 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) GOTO 260 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, III, 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 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) GOTO 260 END IF END DO END IF PLEFTWCB = PLEFTWCB - LIELL*NRHS_B 270 CONTINUE RETURN 260 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_SOLVE_NODE RECURSIVE SUBROUTINE SMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, III, 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, III, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 40 ), 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) #if defined(RHSCOMP_BYROWS) REAL RHSCOMP(NRHS,LRHSCOMP) #else REAL RHSCOMP(LRHSCOMP,NRHS) #endif LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN DOUBLE PRECISION :: TIME_TMP 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 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, III, 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 MUMPS_5.1.2/src/domp_tps_m.F0000664000175000017500000000070113164366264015774 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE DMUMPS_TPS_M_RETURN MUMPS_5.1.2/src/sfac_asm_ELT.F0000664000175000017500000001732113164366262016117 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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(8) :: POSELT 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)) POSELT = PTRAST(STEP(INODE)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS) END IF 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 END DO END IF 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) 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) 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 :: 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)) A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = ZERO NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) 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.1.2/src/slr_stats.F0000664000175000017500000012431113164366263015654 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE SMUMPS_LR_STATS USE SMUMPS_LR_TYPE IMPLICIT NONE DOUBLE PRECISION :: ACC_MRY_CB_GAIN, & ACC_MRY_CB_FR, & FRONT_L11_BLR_SAVINGS, & FRONT_U11_BLR_SAVINGS, & FRONT_L21_BLR_SAVINGS, & FRONT_U12_BLR_SAVINGS, & ACC_FR_MRY, & GLOBAL_BLR_SAVINGS, & GLOBAL_MRY_LPRO_COMPR, & GLOBAL_MRY_LTOT_COMPR INTEGER :: CNT_NODES DOUBLE PRECISION :: FLOP_FR_UPDT, & FLOP_LR_UPDT, & FLOP_LR_UPDT_OUT, & FLOP_RMB, & FLOP_FR_TRSM, & FLOP_LR_TRSM, & FLOP_PANEL, & FLOP_TRSM, & FLOP_DEC_ACC, & FLOP_REC_ACC, & FLOP_DEMOTE, & FLOP_CB_DEMOTE, & FLOP_CB_PROMOTE, & LR_FLOP_GAIN DOUBLE PRECISION :: ACC_LR_FLOP_GAIN DOUBLE PRECISION :: ACC_FLOP_FR_FACTO, & ACC_FLOP_LR_FACTO, & ACC_FLOP_FR_TRSM, & ACC_FLOP_LR_TRSM, & ACC_FLOP_FR_UPDT, & ACC_FLOP_LR_UPDT, & ACC_FLOP_LR_UPDT_OUT, & ACC_FLOP_RMB, & ACC_FLOP_DEMOTE, & ACC_FLOP_CB_DEMOTE, & ACC_FLOP_CB_PROMOTE, & ACC_FLOP_TRSM, & ACC_FLOP_DEC_ACC, & ACC_FLOP_REC_ACC, & ACC_FLOP_PANEL, & ACC_FLOP_FRFRONTS, & ACC_FLOP_FR_SOLVE, & ACC_FLOP_LR_SOLVE DOUBLE PRECISION :: FACTOR_PROCESSED_FRACTION INTEGER(KIND=8) :: FACTOR_SIZE DOUBLE PRECISION :: TOTAL_FLOP DOUBLE PRECISION :: BLR_TIME_LRGROUPING DOUBLE PRECISION :: BLR_TIME_SEPGROUPING DOUBLE PRECISION :: BLR_TIME_GETHALO DOUBLE PRECISION :: BLR_TIME_KWAY DOUBLE PRECISION :: BLR_TIME_GNEW DOUBLE PRECISION :: ACC_UPDT_TIME DOUBLE PRECISION :: ACC_RMB_TIME DOUBLE PRECISION :: ACC_UPDT_TIME_OUT DOUBLE PRECISION :: ACC_PROMOTING_TIME DOUBLE PRECISION :: ACC_DEMOTING_TIME DOUBLE PRECISION :: ACC_CB_DEMOTING_TIME DOUBLE PRECISION :: ACC_LR_MODULE_TIME DOUBLE PRECISION :: ACC_TRSM_TIME DOUBLE PRECISION :: ACC_FRPANELS_TIME DOUBLE PRECISION :: ACC_FAC_I_TIME DOUBLE PRECISION :: ACC_FAC_MQ_TIME DOUBLE PRECISION :: ACC_FAC_SQ_TIME DOUBLE PRECISION :: ACC_FRFRONTS_TIME DOUBLE PRECISION :: AVG_ACC_FLOP_LR_FACTO DOUBLE PRECISION :: MIN_ACC_FLOP_LR_FACTO DOUBLE PRECISION :: MAX_ACC_FLOP_LR_FACTO 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 INTEGER, POINTER :: STEP_STATS(:) 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 UPDATE_ALL_TIMES(INODE, LOC_FACTO_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_FACTO_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_FRFRONTS_TIME, LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME ACC_UPDT_TIME = ACC_UPDT_TIME + LOC_FACTO_TIME ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + LOC_PROMOTING_TIME ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + LOC_DEMOTING_TIME ACC_CB_DEMOTING_TIME = ACC_CB_DEMOTING_TIME + & LOC_CB_DEMOTING_TIME ACC_FRPANELS_TIME = ACC_FRPANELS_TIME + LOC_FRPANELS_TIME ACC_FAC_I_TIME = ACC_FAC_I_TIME + LOC_FAC_I_TIME ACC_FAC_MQ_TIME = ACC_FAC_MQ_TIME + LOC_FAC_MQ_TIME ACC_FAC_SQ_TIME = ACC_FAC_SQ_TIME + LOC_FAC_SQ_TIME ACC_FRFRONTS_TIME = ACC_FRFRONTS_TIME + LOC_FRFRONTS_TIME ACC_TRSM_TIME = ACC_TRSM_TIME + LOC_TRSM_TIME ACC_LR_MODULE_TIME = ACC_LR_MODULE_TIME + LOC_LR_MODULE_TIME END SUBROUTINE UPDATE_ALL_TIMES SUBROUTINE UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_CB_DEMOTING_TIME ACC_CB_DEMOTING_TIME = ACC_CB_DEMOTING_TIME + & LOC_CB_DEMOTING_TIME END SUBROUTINE UPDATE_CB_DEMOTING_TIME SUBROUTINE UPDATE_UPDT_TIME(INODE, LOC_UPDT_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_UPDT_TIME ACC_UPDT_TIME = ACC_UPDT_TIME + LOC_UPDT_TIME END SUBROUTINE UPDATE_UPDT_TIME SUBROUTINE UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) DOUBLE PRECISION, INTENT(IN) :: LOC_UPDT_TIME_OUT ACC_UPDT_TIME_OUT = ACC_UPDT_TIME_OUT + LOC_UPDT_TIME_OUT END SUBROUTINE UPDATE_UPDT_TIME_OUT SUBROUTINE UPDATE_RMB_TIME(LOC_RMB_TIME) DOUBLE PRECISION, INTENT(IN) :: LOC_RMB_TIME ACC_RMB_TIME = ACC_RMB_TIME + LOC_RMB_TIME END SUBROUTINE UPDATE_RMB_TIME SUBROUTINE UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_PROMOTING_TIME ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & LOC_PROMOTING_TIME END SUBROUTINE UPDATE_PROMOTING_TIME SUBROUTINE UPDATE_FLOP_STATS_CB_PROMOTE(COST, NIV) DOUBLE PRECISION :: COST INTEGER :: NIV IF (NIV.EQ.1) THEN !$OMP CRITICAL(cb_flop_cost_pro_cri) FLOP_CB_PROMOTE = FLOP_CB_PROMOTE + COST !$OMP END CRITICAL(cb_flop_cost_pro_cri) ELSE !$OMP CRITICAL(acc_cb_flop_cost_pro_cri) ACC_FLOP_CB_PROMOTE = ACC_FLOP_CB_PROMOTE + COST !$OMP END CRITICAL(acc_cb_flop_cost_pro_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_CB_PROMOTE SUBROUTINE UPDATE_FLOP_STATS_CB_DEMOTE(COST, NIV) DOUBLE PRECISION :: COST INTEGER :: NIV IF (NIV.EQ.1) THEN !$OMP CRITICAL(cb_flop_cost_dem_cri) FLOP_CB_DEMOTE = FLOP_CB_DEMOTE + COST !$OMP END CRITICAL(cb_flop_cost_dem_cri) ELSE !$OMP CRITICAL(acc_cb_flop_cost_dem_cri) ACC_FLOP_CB_DEMOTE = ACC_FLOP_CB_DEMOTE + COST !$OMP END CRITICAL(acc_cb_flop_cost_dem_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_CB_DEMOTE SUBROUTINE UPDATE_FLOP_STATS_DEMOTE(LR_B, NIV, REC_ACC) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER(8) :: M,N,K INTEGER :: NIV DOUBLE PRECISION :: HR_COST,BUILDQ_COST LOGICAL, OPTIONAL :: REC_ACC M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K,8) HR_COST = dble(4_8*K*K*K/3_8 + 4_8*K*M*N - 2_8*(M+N)*K*K) IF (LR_B%ISLR) THEN BUILDQ_COST = dble(4_8*K*K*M - K*K*K) ELSE BUILDQ_COST = 0.0d0 END IF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_DEMOTE = FLOP_DEMOTE + HR_COST + BUILDQ_COST IF (present(REC_ACC)) THEN IF (REC_ACC) THEN FLOP_REC_ACC = FLOP_REC_ACC + HR_COST+BUILDQ_COST ENDIF ENDIF !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + (HR_COST + BUILDQ_COST) IF (present(REC_ACC)) THEN IF (REC_ACC) THEN ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC +HR_COST+BUILDQ_COST ENDIF ENDIF !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_DEMOTE SUBROUTINE UPDATE_FLOP_STATS_REC_ACC(LR_B, NIV, K1, K2, BUILDQ1) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER,INTENT(IN) :: NIV, K1, K2 LOGICAL,INTENT(IN) :: BUILDQ1 INTEGER(8) :: M,N,K DOUBLE PRECISION :: HR_COST, BUILDQ_COST, GS_COST, UPDT_COST, & TOT_COST M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K - K1,8) GS_COST = dble((4_8*(K1)+1_8)*M*K2) HR_COST = dble(4_8*K*K*K/3_8 + 4_8*K*M*K2 - 2_8*(M+K2)*K*K) IF (BUILDQ1) THEN BUILDQ_COST = dble(4_8*K*K*M - K*K*K) UPDT_COST = dble(2_8*K*K2*N) ELSE BUILDQ_COST = 0.0d0 UPDT_COST = 0.0d0 ENDIF TOT_COST = BUILDQ_COST + HR_COST + GS_COST + UPDT_COST IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_DEMOTE = FLOP_DEMOTE + TOT_COST FLOP_REC_ACC = FLOP_REC_ACC + TOT_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + TOT_COST ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + TOT_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_REC_ACC SUBROUTINE UPDATE_FLOP_STATS_PANEL(NFRONT, NPIV, NIV, SYM) INTEGER :: NFRONT, NPIV, NIV, SYM DOUBLE PRECISION :: COST_PANEL, COST_TRSM IF (SYM.EQ.0) THEN COST_TRSM = dble(2 * NPIV-1) * dble(NPIV) & * dble(NFRONT-NPIV) COST_PANEL = dble(NPIV) * dble(NPIV - 1) & * dble(4 * NPIV + 1)/dble(6) ELSE COST_TRSM = dble(NPIV) * dble(NPIV) * dble(NFRONT-NPIV) COST_PANEL = dble(NPIV) * dble(NPIV - 1) & * dble(2 * NPIV + 1)/dble(6) ENDIF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_PANEL = FLOP_PANEL + COST_PANEL FLOP_TRSM = FLOP_TRSM + COST_TRSM !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_PANEL = ACC_FLOP_PANEL + COST_PANEL ACC_FLOP_TRSM = ACC_FLOP_TRSM + COST_TRSM !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_PANEL SUBROUTINE UPDATE_FLOP_STATS_TRSM(LRB, NIV, LorU, K470) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: NIV, LorU, K470 DOUBLE PRECISION :: LR_FLOP_COST, FR_FLOP_COST IF (LorU.EQ.0) THEN FR_FLOP_COST = dble(LRB%M)*dble(LRB%N)*dble(LRB%N) IF (LRB%ISLR) THEN LR_FLOP_COST = dble(LRB%K)*dble(LRB%N)*dble(LRB%N) ELSE LR_FLOP_COST = FR_FLOP_COST ENDIF ELSE IF (K470.EQ.1) THEN FR_FLOP_COST = dble(LRB%M-1)*dble(LRB%N)*dble(LRB%N) ELSE FR_FLOP_COST = dble(LRB%M-1)*dble(LRB%M)*dble(LRB%N) ENDIF IF (LRB%ISLR) THEN IF (K470.EQ.1) THEN LR_FLOP_COST = dble(LRB%N-1)*dble(LRB%N)*dble(LRB%K) ELSE LR_FLOP_COST = dble(LRB%M-1)*dble(LRB%M)*dble(LRB%K) ENDIF ELSE LR_FLOP_COST = FR_FLOP_COST ENDIF ENDIF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_FR_TRSM = FLOP_FR_TRSM + FR_FLOP_COST FLOP_LR_TRSM = FLOP_LR_TRSM + LR_FLOP_COST LR_FLOP_GAIN = LR_FLOP_GAIN + FR_FLOP_COST & - LR_FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_FR_TRSM = ACC_FLOP_FR_TRSM + FR_FLOP_COST ACC_FLOP_LR_TRSM = ACC_FLOP_LR_TRSM + LR_FLOP_COST ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + FR_FLOP_COST & - LR_FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) END IF END SUBROUTINE UPDATE_FLOP_STATS_TRSM SUBROUTINE UPDATE_FLOP_STATS_LRB_PRODUCT(LRB1, LRB2, TRANSB1, & TRANSB2, NIV, COMPRESS_MID_PRODUCT, RANK_IN, BUILDQ, & IS_DIAG, K480, REC_ACC_IN) !$ USE OMP_LIB TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 CHARACTER(len=1), INTENT(IN) :: TRANSB1, TRANSB2 LOGICAL, INTENT(IN), OPTIONAL :: BUILDQ, IS_DIAG, REC_ACC_IN INTEGER, INTENT(IN), OPTIONAL :: NIV, RANK_IN, & COMPRESS_MID_PRODUCT, K480 LOGICAL :: REC_ACC DOUBLE PRECISION :: LR_FLOP_COST, LR_FLOP_COST_OUT, FR_FLOP_COST DOUBLE PRECISION :: HR_COST, BUILDQ_COST DOUBLE PRECISION :: M1,N1,K1,M2,N2,K2,RANK CHARACTER(len=2) :: PROD, TRANS IF(present(K480).AND.present(REC_ACC_IN)) THEN IF (K480.GE.4) THEN REC_ACC = REC_ACC_IN ELSE REC_ACC = .FALSE. ENDIF ELSE REC_ACC = .FALSE. ENDIF 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) IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) THEN PROD = '00' ELSE IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN PROD = '10' ELSE IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN PROD = '01' ELSE PROD = '11' END IF IF ((TRANSB1=='N').AND.(TRANSB2=='N')) THEN TRANS = 'NN' ELSE IF ((TRANSB1=='T').AND.(TRANSB2=='N')) THEN TRANS = 'TN' ELSE IF ((TRANSB1=='N').AND.(TRANSB2=='T')) THEN TRANS = 'NT' ELSE TRANS = 'TT' END IF LR_FLOP_COST_OUT = 0.0D0 HR_COST = 0.0D0 BUILDQ_COST = 0.0D0 SELECT CASE (PROD) CASE('00') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*M1*N2*N1 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*M1*N2*N1 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*M1*M2*N1 CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 LR_FLOP_COST = 2.0D0*N1*M2*M1 END SELECT CASE('10') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*K1*N2*N1 + 2.0D0*M1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K1 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*K1*N2*M1 + 2.0D0*N1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K1 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*K1*M2*N1 + 2.0D0*M1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K1 CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 LR_FLOP_COST = 2.0D0*K1*M2*M1 + 2.0D0*N1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K1 END SELECT CASE('01') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*M1*K2*N1 + 2.0D0*M1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K2 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*N1*K2*M1 + 2.0D0*N1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K2 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*M1*K2*N1 + 2.0D0*M1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K2 CASE('TT') FR_FLOP_COST = 2*N1*M2*M1 LR_FLOP_COST = 2.0D0*N1*K2*M1 + 2.0D0*N1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K2 END SELECT CASE('11') IF (COMPRESS_MID_PRODUCT.GE.1) THEN HR_COST = 4.0D0*RANK*RANK*RANK/3.0D0 + & 4.0D0*RANK*K1*K2 - & 2.0D0*(K1+K2)*RANK*RANK IF (BUILDQ) THEN BUILDQ_COST = 4.0D0*RANK*RANK*K1 - RANK*RANK*RANK ENDIF ENDIF SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*RANK + 2.0D0*K2*N2*RANK + & 2.0D0*M1*N2*RANK LR_FLOP_COST_OUT = 2.0D0*M1*N2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*K2 + 2.0D0*M1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*N2*K2 + 2.0D0*M1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K1 ENDIF ENDIF CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*RANK + 2.0D0*K2*N2*RANK + & 2.0D0*N1*N2*RANK LR_FLOP_COST_OUT = 2.0D0*N1*N2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*K2 + 2.0D0*N1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N2*K2 + 2.0D0*N1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K1 ENDIF ENDIF CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*RANK + 2.0D0*K2*M2*RANK + & 2.0D0*M1*M2*RANK LR_FLOP_COST_OUT = 2.0D0*M1*M2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*K2 + 2.0D0*M1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M2*K2 + 2.0D0*M1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K1 ENDIF ENDIF CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*RANK + 2.0D0*K2*M2*RANK + & 2.0D0*N1*M2*RANK LR_FLOP_COST_OUT = 2.0D0*N1*M2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*K2 + 2.0D0*N1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*M2*K2 + 2.0D0*N1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K1 ENDIF ENDIF END SELECT END SELECT IF (present(IS_DIAG)) THEN IF (IS_DIAG) THEN FR_FLOP_COST = FR_FLOP_COST/2.0D0 LR_FLOP_COST = LR_FLOP_COST/2.0D0 ENDIF ENDIF IF (present(K480)) THEN IF (K480.GE.3) THEN LR_FLOP_COST = LR_FLOP_COST - LR_FLOP_COST_OUT LR_FLOP_COST_OUT = 0.0D0 IF (REC_ACC) THEN IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_REC_ACC = FLOP_REC_ACC + LR_FLOP_COST & + HR_COST + BUILDQ_COST FLOP_DEMOTE = FLOP_DEMOTE + LR_FLOP_COST & + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + LR_FLOP_COST & + HR_COST + BUILDQ_COST ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + LR_FLOP_COST & + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF ENDIF ENDIF ENDIF IF (.NOT.REC_ACC) THEN IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) LR_FLOP_GAIN = LR_FLOP_GAIN + FR_FLOP_COST - LR_FLOP_COST FLOP_FR_UPDT = FLOP_FR_UPDT + FR_FLOP_COST FLOP_LR_UPDT = FLOP_LR_UPDT + LR_FLOP_COST FLOP_LR_UPDT_OUT = FLOP_LR_UPDT_OUT + LR_FLOP_COST_OUT FLOP_DEMOTE = FLOP_DEMOTE + HR_COST + BUILDQ_COST FLOP_RMB = FLOP_RMB + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + & FR_FLOP_COST - LR_FLOP_COST ACC_FLOP_FR_UPDT = ACC_FLOP_FR_UPDT + FR_FLOP_COST ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + LR_FLOP_COST ACC_FLOP_LR_UPDT_OUT = ACC_FLOP_LR_UPDT_OUT + & LR_FLOP_COST_OUT ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + HR_COST + BUILDQ_COST ACC_FLOP_RMB = ACC_FLOP_RMB + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF ENDIF END SUBROUTINE UPDATE_FLOP_STATS_LRB_PRODUCT SUBROUTINE UPDATE_FLOP_STATS_DEC_ACC(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) IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) LR_FLOP_GAIN = LR_FLOP_GAIN - FLOP_COST FLOP_LR_UPDT = FLOP_LR_UPDT + FLOP_COST FLOP_LR_UPDT_OUT = FLOP_LR_UPDT_OUT + FLOP_COST FLOP_DEC_ACC = FLOP_DEC_ACC + FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN - FLOP_COST ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + FLOP_COST ACC_FLOP_LR_UPDT_OUT = ACC_FLOP_LR_UPDT_OUT + & FLOP_COST ACC_FLOP_DEC_ACC = ACC_FLOP_DEC_ACC + FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_DEC_ACC SUBROUTINE UPDATE_FLOPS_STATS_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)) ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + COST_PER_PROC RETURN END SUBROUTINE UPDATE_FLOPS_STATS_ROOT SUBROUTINE INIT_STATS_FRONT(NFRONT,INODE,NASS,NCB) INTEGER,INTENT(IN) :: NFRONT,INODE,NASS,NCB FRONT_L11_BLR_SAVINGS = 0.D0 FRONT_U11_BLR_SAVINGS = 0.D0 FRONT_L21_BLR_SAVINGS = 0.D0 FRONT_U12_BLR_SAVINGS = 0.D0 LR_FLOP_GAIN = 0.D0 FLOP_CB_DEMOTE = 0.D0 FLOP_CB_PROMOTE = 0.D0 FLOP_FR_UPDT = 0.D0 FLOP_LR_UPDT = 0.D0 FLOP_LR_UPDT_OUT = 0.D0 FLOP_RMB = 0.D0 FLOP_FR_TRSM = 0.D0 FLOP_LR_TRSM = 0.D0 FLOP_DEMOTE = 0.D0 FLOP_DEC_ACC = 0.D0 FLOP_REC_ACC = 0.D0 FLOP_PANEL = 0.D0 FLOP_TRSM = 0.D0 END SUBROUTINE INIT_STATS_FRONT SUBROUTINE INIT_STATS_GLOBAL(id) use SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id ACC_MRY_CB_GAIN = 0.D0 ACC_MRY_CB_FR = 0.D0 ACC_FLOP_CB_DEMOTE = 0.D0 ACC_FLOP_CB_PROMOTE = 0.D0 ACC_FLOP_FR_FACTO = 0.D0 ACC_FLOP_LR_FACTO = 0.D0 ACC_FLOP_FR_UPDT = 0.D0 ACC_FLOP_LR_UPDT = 0.D0 ACC_FLOP_LR_UPDT_OUT = 0.D0 ACC_FLOP_RMB = 0.D0 ACC_FLOP_FR_TRSM = 0.D0 ACC_FLOP_LR_TRSM = 0.D0 ACC_FLOP_DEMOTE = 0.D0 ACC_FLOP_TRSM = 0.D0 ACC_FLOP_DEC_ACC = 0.D0 ACC_FLOP_REC_ACC = 0.D0 ACC_FLOP_PANEL = 0.D0 ACC_FLOP_FRFRONTS = 0.D0 ACC_FLOP_FR_SOLVE = 0.D0 ACC_FLOP_LR_SOLVE = 0.D0 ACC_LR_FLOP_GAIN = 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 ACC_FR_MRY = 0.D0 GLOBAL_BLR_SAVINGS = 0.D0 ACC_UPDT_TIME = 0.D0 ACC_UPDT_TIME_OUT = 0.D0 ACC_RMB_TIME = 0.D0 ACC_PROMOTING_TIME = 0.D0 ACC_DEMOTING_TIME = 0.D0 ACC_CB_DEMOTING_TIME = 0.D0 ACC_FRPANELS_TIME = 0.0D0 ACC_FAC_I_TIME = 0.0D0 ACC_FAC_MQ_TIME = 0.0D0 ACC_FAC_SQ_TIME = 0.0D0 ACC_FRFRONTS_TIME = 0.0D0 ACC_TRSM_TIME = 0.D0 ACC_LR_MODULE_TIME = 0.D0 CNT_NODES = 0 STEP_STATS => id%STEP END SUBROUTINE INIT_STATS_GLOBAL SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NCB, & SYM, INODE, NELIM) INTEGER,INTENT(IN) :: NASS, NCB, SYM, INODE, NELIM DOUBLE PRECISION :: FRONT_BLR_SAVINGS, FRONT_FR_MRY IF (SYM .GT. 0) THEN FRONT_BLR_SAVINGS = FRONT_L11_BLR_SAVINGS & + FRONT_L21_BLR_SAVINGS FRONT_FR_MRY = dble(NASS-NELIM) * & (dble(NASS-NELIM)+1.D0)/2.D0 & + dble(NASS-NELIM) * dble(NCB+NELIM) ELSE FRONT_BLR_SAVINGS = FRONT_L11_BLR_SAVINGS & + FRONT_L21_BLR_SAVINGS & + FRONT_U11_BLR_SAVINGS & + FRONT_U12_BLR_SAVINGS FRONT_FR_MRY = dble(NASS-NELIM) * dble(NASS-NELIM) & + 2.0D0 * dble(NASS-NELIM) * dble(NCB+NELIM) END IF ACC_FR_MRY = ACC_FR_MRY + FRONT_FR_MRY GLOBAL_BLR_SAVINGS = GLOBAL_BLR_SAVINGS + FRONT_BLR_SAVINGS END SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE1 SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, & SYM, INODE, NELIM) INTEGER,INTENT(IN) :: NASS, NFRONT, SYM, INODE, NELIM IF (SYM .GT. 0) THEN ACC_FR_MRY = ACC_FR_MRY + & dble(NASS-NELIM) * & (dble(NASS-NELIM)+1.D0)/2.D0 & + dble(NASS-NELIM) * dble(NFRONT-NASS+NELIM) ELSE ACC_FR_MRY = ACC_FR_MRY + & dble(NASS-NELIM) * dble(NASS-NELIM) & + 2.0D0 * dble(NASS-NELIM) * dble(NFRONT-NASS+NELIM) ENDIF END SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE2 SUBROUTINE STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, & SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS) INTEGER,INTENT(IN) :: NROW, NCB, SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS DOUBLE PRECISION :: MRY_CB_FR IF (SYM==0) THEN MRY_CB_FR = dble(NCB)*dble(NROW) ELSE MRY_CB_FR = dble(NCB-NROW)*dble(NROW) + & dble(NROW)*dble(NROW+1)/2.D0 ENDIF ACC_MRY_CB_FR = ACC_MRY_CB_FR + MRY_CB_FR ACC_MRY_CB_GAIN = ACC_MRY_CB_GAIN + FRONT_CB_BLR_SAVINGS END SUBROUTINE STATS_COMPUTE_MRY_FRONT_CB SUBROUTINE STATS_STORE_BLR_PANEL_MRY(BLR_PANEL, NB_INASM, & NB_INCB, DIR, NIV) INTEGER,INTENT(IN) :: NB_INASM, NB_INCB, NIV TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(NB_INASM+NB_INCB) CHARACTER(len=1) :: DIR INTEGER :: I IF (NB_INASM.GT.0.AND.DIR .EQ.'V') THEN ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + & dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N) ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N) ENDIF DO I = 1 , NB_INASM ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + & dble(2)*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) IF (BLR_PANEL(I)%ISLR) THEN ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(4)*(dble(BLR_PANEL(I)%M)+dble(BLR_PANEL(I)%N))* & dble(BLR_PANEL(I)%K) IF (DIR .EQ. 'H') THEN IF (NIV .EQ. 1) THEN FRONT_U11_BLR_SAVINGS = & FRONT_U11_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ELSE IF (NIV .EQ. 1) THEN FRONT_L11_BLR_SAVINGS = & FRONT_L11_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M) + dble(BLR_PANEL(I)%N ) ENDIF ENDIF ELSE ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(2)*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) ENDIF END DO DO I = NB_INASM + 1 , NB_INASM + NB_INCB IF (BLR_PANEL(I)%ISLR) THEN IF (DIR .EQ. 'H') THEN IF (NIV .EQ. 1) THEN FRONT_U12_BLR_SAVINGS = & FRONT_U12_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ELSE IF (NIV .EQ. 1) THEN FRONT_L21_BLR_SAVINGS = & FRONT_L21_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble ( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ENDIF END IF END DO END SUBROUTINE STATS_STORE_BLR_PANEL_MRY SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE1( NFRONT, NASS, NPIV, & KEEP50, INODE) INTEGER,INTENT(IN) :: NFRONT, KEEP50, NASS, NPIV, INODE DOUBLE PRECISION :: FLOP_FR_FACTO CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & KEEP50, 1, FLOP_FR_FACTO) ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + LR_FLOP_GAIN ACC_FLOP_FR_UPDT = ACC_FLOP_FR_UPDT + FLOP_FR_UPDT ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + FLOP_LR_UPDT ACC_FLOP_LR_UPDT_OUT= ACC_FLOP_LR_UPDT_OUT+ FLOP_LR_UPDT_OUT ACC_FLOP_RMB = ACC_FLOP_RMB + FLOP_RMB ACC_FLOP_FR_TRSM = ACC_FLOP_FR_TRSM + FLOP_FR_TRSM ACC_FLOP_LR_TRSM = ACC_FLOP_LR_TRSM + FLOP_LR_TRSM ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + FLOP_DEMOTE ACC_FLOP_CB_DEMOTE = ACC_FLOP_CB_DEMOTE + FLOP_CB_DEMOTE ACC_FLOP_CB_PROMOTE = ACC_FLOP_CB_PROMOTE + FLOP_CB_PROMOTE ACC_FLOP_DEC_ACC = ACC_FLOP_DEC_ACC + FLOP_DEC_ACC ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + FLOP_REC_ACC ACC_FLOP_TRSM = ACC_FLOP_TRSM + FLOP_TRSM ACC_FLOP_PANEL = ACC_FLOP_PANEL + FLOP_PANEL END SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE1 SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE2( NFRONT, NASS, & KEEP50, INODE, NELIM) INTEGER,INTENT(IN) :: NFRONT, KEEP50, NASS, INODE, NELIM DOUBLE PRECISION :: FLOP_FR_FACTO CALL MUMPS_GET_FLOPS_COST(NFRONT, NASS-NELIM, NASS, & KEEP50, 2, FLOP_FR_FACTO) ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO END SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE2 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_FR_FACTO NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP_FR_FACTO = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP_FR_FACTO = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO END SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2 SUBROUTINE UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, SYM, & NIV) INTEGER, INTENT(IN) :: NFRONT, NPIV, NASS, SYM, NIV DOUBLE PRECISION :: FLOP_FRFRONTS, FLOP_SOLVE CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP_FRFRONTS) ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + FLOP_FRFRONTS FLOP_SOLVE = dble(NASS)*dble(NASS) + & dble(NFRONT-NASS)*dble(NASS) IF (SYM.EQ.0) FLOP_SOLVE = 2.0D0*FLOP_SOLVE ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + FLOP_SOLVE ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + FLOP_SOLVE END SUBROUTINE UPDATE_FLOP_STATS_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_FRFRONTS NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP_FRFRONTS = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP_FRFRONTS = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + FLOP_FRFRONTS END SUBROUTINE UPD_FLOP_FRFRONT_SLAVE SUBROUTINE COMPUTE_GLOBAL_GAINS(NB_ENTRIES_FACTOR, & FLOP_NUMBER, NIV, PROKG, MPG) INTEGER(KIND=8), INTENT(IN) :: NB_ENTRIES_FACTOR INTEGER, INTENT(IN) :: NIV, MPG LOGICAL, INTENT(IN) :: PROKG REAL , INTENT(IN) :: FLOP_NUMBER 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 (ACC_FR_MRY .EQ. 0) THEN GLOBAL_MRY_LPRO_COMPR = 100.0D0 ELSE GLOBAL_MRY_LPRO_COMPR = 100.0D0 * & GLOBAL_BLR_SAVINGS/ACC_FR_MRY ENDIF IF (ACC_MRY_CB_FR .EQ. 0) THEN ACC_MRY_CB_FR = 100.0D0 END IF IF (NB_ENTRIES_FACTOR.EQ.0) THEN FACTOR_PROCESSED_FRACTION = 100.0D0 GLOBAL_MRY_LTOT_COMPR = 100.0D0 ELSE FACTOR_PROCESSED_FRACTION = 100.0D0 * & ACC_FR_MRY/dble(NB_ENTRIES_FACTOR) GLOBAL_MRY_LTOT_COMPR = & 100.0D0*GLOBAL_BLR_SAVINGS/dble(NB_ENTRIES_FACTOR) ENDIF TOTAL_FLOP = FLOP_NUMBER ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN & + ACC_FLOP_DEMOTE RETURN END SUBROUTINE COMPUTE_GLOBAL_GAINS SUBROUTINE SAVEandWRITE_GAINS(LOCAL, K489, DKEEP, N, & DEPTH, BCKSZ, NASSMIN, NFRONTMIN, SYM, K486, & K472, K475, K478, K480, K481, K483, K484, K485, K467, & NBTREENODES, NPROCS, MPG, PROKG) INTEGER, INTENT(IN) :: LOCAL,K489,N,DEPTH,BCKSZ,NASSMIN, & NFRONTMIN, K486, NBTREENODES, MPG, K467, & K472, K475, K478, K480, K481, K483, K484, K485, SYM, NPROCS 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)') & ' Settings for Block Low-Rank (BLR) are :' WRITE(MPG,'(A)') ' BLR algorithm characteristics :' WRITE(MPG,'(A,A)') ' Variant used: FSCU ', & '(Factor-Solve-Compress-Update)' SELECT CASE (K489) CASE (0) CASE (1) WRITE(MPG,'(A)') & ' Experimental CB compression (for stats only)' CASE DEFAULT WRITE(*,*)' Internal error K489=',K489 CALL MUMPS_ABORT() END SELECT IF (K472.EQ.0) THEN WRITE(MPG,'(A,A,I4)') ' Target BLR block size (fixed)', & ' =', & BCKSZ ELSE WRITE(MPG,'(A,A,I4,A,I4)') & ' Target BLR block size (variable)', & ' =', & 128, ' -', BCKSZ ENDIF WRITE(MPG,'(A,A,ES8.1)') ' RRQR precision (epsilon) ', & ' =', & 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)') & ' 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(ACC_FLOP_LR_FACTO+ACC_FLOP_FRFRONTS) DKEEP(61)=real(100*(ACC_FLOP_LR_FACTO+ & ACC_FLOP_FRFRONTS) /TOTAL_FLOP) IF (PROK) THEN WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' Total theoretical full-rank OPC (i.e. FR OPC) =' & ,TOTAL_FLOP,' (',100*TOTAL_FLOP/TOTAL_FLOP,'%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' Total effective OPC (% FR OPC) =' & ,ACC_FLOP_LR_FACTO+ACC_FLOP_FRFRONTS,' (' &,100*(ACC_FLOP_LR_FACTO+ACC_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.1.2/src/dfac_process_contrib_type3.F0000664000175000017500000002470413164366263021142 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS,SLAVEF ) USE DMUMPS_LOAD USE DMUMPS_OOC IMPLICIT NONE INCLUDE 'dmumps_root.h' 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 ), NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)),SLAVEF DOUBLE PRECISION A( LA ) INTEGER MYID INTEGER FILS( N ) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N ) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION DBLARR(KEEP8(26)) 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 NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT))-1 #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) - 1 CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)),KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN #endif 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(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 NBPROCFILS(STEP( IROOT ) ) = -1 #if ! defined(NO_XXNBPR) KEEP(121)=-1 #endif ENDIF IF (KEEP(60) == 0) THEN CALL DMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N, & IW, LIW, A, LA, & FILS, MYID, 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 ELSE PTRIST(STEP(IROOT)) = -55555 ENDIF 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, PTRIST, & PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, 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 ) CALL DMUMPS_ASS_ROOT( 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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, PTRIST, & PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, 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 ) IF (KEEP(60).EQ.0) THEN CALL DMUMPS_ASS_ROOT( 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( 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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.1.2/src/mumps_io_basic.c0000664000175000017500000007321113164366240016661 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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,*_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,*_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.1.2/src/fac_maprow_data_m.F0000664000175000017500000002433213164366241017257 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/dsol_matvec.F0000664000175000017500000002377613164366266016156 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(out) :: 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.1.2/src/cfac_process_contrib_type3.F0000664000175000017500000002461313164366264021141 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS,SLAVEF ) USE CMUMPS_LOAD USE CMUMPS_OOC IMPLICIT NONE INCLUDE 'cmumps_root.h' 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 ), NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)),SLAVEF COMPLEX A( LA ) INTEGER MYID INTEGER FILS( N ) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N ) INTEGER INTARR(KEEP8(27)) COMPLEX DBLARR(KEEP8(26)) 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 NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT))-1 #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) - 1 CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)),KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN #endif 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(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 NBPROCFILS(STEP( IROOT ) ) = -1 #if ! defined(NO_XXNBPR) KEEP(121)=-1 #endif ENDIF IF (KEEP(60) == 0) THEN CALL CMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N, & IW, LIW, A, LA, & FILS, MYID, 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 ELSE PTRIST(STEP(IROOT)) = -55555 ENDIF 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, PTRIST, & PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, 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 ) CALL CMUMPS_ASS_ROOT( 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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, PTRIST, & PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, 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 ) IF (KEEP(60).EQ.0) THEN CALL CMUMPS_ASS_ROOT( 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( 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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.1.2/src/sfac_omp_m.F0000664000175000017500000000117613164366266015747 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C C SUBROUTINE SMUMPS_FAC_L0_OMP_RETURN() C C Research work on multithreaded tree parallelism initiated in C the context of the PhD thesis of Wissam Sid-Lakhdar (ENS Lyon) C might impact a future release. C RETURN END SUBROUTINE SMUMPS_FAC_L0_OMP_RETURN MUMPS_5.1.2/src/csol_c.F0000664000175000017500000026276513164366264015121 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, PTR_RHS_ROOT, LPTR_RHS_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 , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS & ) USE CMUMPS_OOC USE MUMPS_SOL_ES IMPLICIT NONE INCLUDE 'cmumps_root.h' #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(40),INFO(40), KEEP(500) 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)) #if defined(RHSCOMP_BYROWS) COMPLEX :: RHSCOMP(NRHS, LRHSCOMP) #else COMPLEX :: RHSCOMP(LRHSCOMP,NRHS) #endif 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) :: LPTR_RHS_ROOT COMPLEX PTR_RHS_ROOT(LPTR_RHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,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 INTEGER IZERO 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 PARAMETER (IZERO = 0 ) COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mumps_headers.h' 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) :: LPTR_RHS_BOUNDS INTEGER, intent(inout) :: PTR_RHS_BOUNDS (LPTR_RHS_BOUNDS) REAL, intent(inout) :: DKEEP(230) 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, DIMENSION(:), ALLOCATABLE :: prun_NA INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP, INODE_PRINC LOGICAL AM1, DO_PRUN LOGICAL Exploit_Sparsity LOGICAL DO_NBSPARSE_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 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 = KEEP(28)+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 IF (.not. allocated(Pruned_SONS)) 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 END IF IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (.not. allocated(TO_PROCESS)) THEN SIZE_TO_PROCESS = KEEP(28) 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 END IF TO_PROCESS(:) = .TRUE. ENDIF 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 MUMPS_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 MUMPS_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 MUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), 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 MUMPS_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), & PTR_RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL MUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, PTR_RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, & 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 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 CMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE, & FROM_PP & ) ELSE ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), & STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves+nb_prun_roots+2 END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 prun_NA(1) = nb_prun_leaves prun_NA(2) = nb_prun_roots DO I = 1, nb_prun_leaves prun_NA(I+2) = Pruned_Leaves(I) ENDDO DO I = 1, nb_prun_roots prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) ENDDO DEALLOCATE(Pruned_List) DEALLOCATE(Pruned_Leaves) IF (AM1) THEN DEALLOCATE(Pruned_Roots) END IF IF ((Exploit_Sparsity).AND.(nb_prun_roots.EQ.NA(2))) THEN DEALLOCATE(Pruned_Roots) IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) SWITCH_OFF_ES = .TRUE. ENDIF CALL CMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & Pruned_SONS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) DEALLOCATE(prun_NA) 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. 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 MUMPS_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 MUMPS_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 MUMPS_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 PTR_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, & PTR_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 (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF 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 ( AM1 ) THEN CALL MUMPS_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 MUMPS_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 MUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL MUMPS_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), & PTR_RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL MUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, PTR_RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, & 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 = IZERO 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 PTR_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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,II) = ZERO #else RHSCOMP(II, K) = ZERO #endif ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN ) THEN SIZE_TO_PROCESS = 1 IF (allocated(TO_PROCESS)) DEALLOCATE(TO_PROCESS) ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) TO_PROCESS(:) = .TRUE. 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, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, DKEEP, & PTR_RHS_ROOT, LPTR_RHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE_BWD, & FROM_PP & ) ELSE ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), & STAT=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of prun_na' CALL MUMPS_ABORT() END IF prun_NA(1) = nb_prun_leaves prun_NA(2) = nb_prun_roots DO I = 1, nb_prun_leaves prun_NA(I+2) = Pruned_Leaves(I) ENDDO DO I = 1, nb_prun_roots prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) ENDDO 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, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & PTR_RHS_ROOT, LPTR_RHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP) ENDIF #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 #if defined(RHSCOMP_BYROWS) K = min0(10,size(RHSCOMP,2)) IF (LDIAG.EQ.4) K = size(RHSCOMP,2) WRITE (MP,99992) IF (size(RHSCOMP,2).GT.0) & WRITE (MP,99993) (RHSCOMP(1,I),I=1,K) IF (size(RHSCOMP,2).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSCOMP(2,I),I=1,K) #else K = min0(10,size(RHSCOMP,1)) IF (LDIAG.EQ.4) K = size(RHSCOMP,1) 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(prun_NA)) DEALLOCATE (prun_NA) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (first column)'/(1X,1P,5E14.6)) 99994 FORMAT (' RHS (2 nd column)'/(1X,1P,5E14.6)) 99992 FORMAT (//' LEAVING SOLVE (MPI41C) 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) #if defined(RHSCOMP_BYROWS) COMPLEX, intent(in) :: RHSCOMP(NCOL_RHSCOMP, LRHSCOMP) #else COMPLEX, intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) #endif 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 PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP INTEGER SK38, SK20 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 MUMPS_PROCNODE 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 = N/2 !$ 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)) !$ 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) # else RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) # endif 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) # else RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) # endif 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 = N/2 !$ 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)) !$ 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = RHSCOMP(J,IPOSINRHSCOMP) # else RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) # endif 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = RHSCOMP(J,IPOSINRHSCOMP) # else RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) # endif 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 defined(RHSCOMP_BYROWS) IF (LCWORK .LT. NRHS) THEN WRITE(*,*) MYID, & ": Internal error 2 in CMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF #else 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 #endif IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247))) 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 (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) THEN IPOS = PTRIST(ISTEP)+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV 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 (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) #if defined(RHSCOMP_BYROWS) DO I=1,NPIV II=IROWLIST(I) CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NRHS, MPI_COMPLEX, & COMM, IERR) IF (LSCAL.AND.KEEP(242).EQ.0) THEN DO J=1,NRHS JCOL_RHS = J+JBEG_RHS-1 RHS(II,JCOL_RHS) = CWORK(J)*SCALING(II) ENDDO ELSE IF ((.NOT. LSCAL).AND.(KEEP(242).EQ.0)) THEN DO J=1,NRHS JCOL_RHS = J+JBEG_RHS-1 RHS(II,JCOL_RHS) = CWORK(J) ENDDO ELSE IF (LSCAL.AND.KEEP(242).NE.0) THEN DO J=1,NRHS JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) RHS(II,JCOL_RHS) = CWORK(J)*SCALING(II) ENDDO ELSE DO J=1,NRHS JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) RHS(II,JCOL_RHS) = CWORK(J) ENDDO ENDIF ENDDO #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 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 #endif 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 defined(RHSCOMP_BYROWS) IF (KEEP(242).EQ.0) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) IF (LSCAL) THEN DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) ENDDO ELSE DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(J,IPOSINRHSCOMP) ENDDO ENDIF ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(J,IPOSINRHSCOMP) IF (LSCAL) THEN RHS(I,PERM_RHS(J+JBEG_RHS-1)) = RHS(I,PERM_RHS(J+JBEG_RHS-1))*SCALING(I) ENDIF ENDDO ENDDO ENDIF #else 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) 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) DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF 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)) #if defined(RHSCOMP_BYROWS) DO II=1,NPIV DO J=1, NRHS CWORK(J) = RHSCOMP(J,IPOSINRHSCOMP+II-1) ENDDO CALL MPI_PACK(CWORK(1), NRHS, & MPI_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO #else DO J=1,NRHS CALL MPI_PACK(RHSCOMP(IPOSINRHSCOMP,J), NPIV, & MPI_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO #endif 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 #if defined(RHSCOMP_BYROWS) COMPLEX, intent(in) :: RHSCOMP (NRHSCOMP_COL,LRHSCOMP) #else COMPLEX, intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL) #endif 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 #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)= & RHSCOMP(K,IPOSINRHSCOMP)*SCALING(I) #else RHS_SPARSE_COPY(IZ)= & RHSCOMP(IPOSINRHSCOMP,K)*SCALING(I) #endif ELSE #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)=RHSCOMP(K,IPOSINRHSCOMP) #else RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) #endif 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 #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)=RHSCOMP(K,IPOSINRHSCOMP) #else RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) #endif 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) 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 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 INTEGER SK38,SK20 INCLUDE 'mumps_headers.h' IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 DO JJ=J1,J1+NPIV-1 K=K+1 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 ) # if defined(RHSCOMP_BYROWS) COMPLEX RHSCOMP( NBRHS_EFF, LRHSCOMP ) # else COMPLEX RHSCOMP( LRHSCOMP, NBRHS_EFF ) # endif 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), & SLAVEF)) 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 ((KEEP(242) .EQ. 0).AND.(KEEP(350).EQ.0)) THEN KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 IPOSINRHSCOMP = POSINRHSCOMP(IW(JJ)) IF (NB_RHSSKIPPED.GT.0) THEN SOL_LOC(KLOC, BEG_RHS:JEMPTY) = ZERO ENDIF IF (LSCAL) THEN # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(1:NBRHS_EFF,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,1:NBRHS_EFF) # endif ELSE # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JEMPTY+1:JEND) = & RHSCOMP(1:NBRHS_EFF,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JEMPTY+1:JEND) = & RHSCOMP(IPOSINRHSCOMP,1:NBRHS_EFF) # endif ENDIF ENDDO ELSE 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+1) .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 # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(JCOL-JEMPTY,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) # endif ELSE # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(JCOL-JEMPTY,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) # endif ENDIF ENDDO ENDDO !$OMP END PARALLEL DO ENDIF 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(40), INFO(40) COMPLEX, intent(in) :: RHS (LRHS, NCOL_RHS) #if defined(RHSCOMP_BYROWS) COMPLEX, intent(out) :: RHSCOMP(NCOL_RHSCOMP, LRHSCOMP) #else COMPLEX, intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) #endif 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 SK38, SK20 !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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 #if defined(RHSCOMP_BYROWS) DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP DO K=1, NCOL_RHSCOMP RHSCOMP (K, I) = ZERO ENDDO ENDDO #else DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO #endif 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& FIRSTPRIVATE(BUF_EFFSIZE) 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 #if defined(RHSCOMP_BYROWS) DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP DO K=1, NCOL_RHSCOMP RHSCOMP (K, I) = ZERO ENDDO ENDDO #else DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO #endif ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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)) END IF 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 defined(RHSCOMP_BYROWS) DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSCOMP( K, INDX+JJ-J1 ) = RHS( J, K ) ENDDO ENDDO #else 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(J1,NPIV,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 #endif 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& FIRSTPRIVATE(BUF_EFFSIZE) IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) #if defined(RHSCOMP_BYROWS) RHSCOMP( K, INDX ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE ) #else RHSCOMP( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) #endif 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 #if defined(RHSCOMP_BYROWS) RHSCOMP( K, INDX ) = BUF_RHS( K, I ) #else RHSCOMP( INDX, K ) = BUF_RHS( K, I ) #endif 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 SK38, SK20, IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 SK38, SK20, 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 IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 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.1.2/src/mumps_save_restore_C.c0000664000175000017500000000114413164366240020050 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html * */ #include #include #include #include "mumps_save_restore_C.h" #include "mumps_common.h" void MUMPS_CALL MUMPS_SAVE_RESTORE_RETURN_C() { // // Save/restore feature will be available in the future // } MUMPS_5.1.2/src/srank_revealing.F0000664000175000017500000000477713164366263017025 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), MPG KEEP(19)=0 RETURN END SUBROUTINE SMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE SMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL,KEEP,MPG,INFO) IMPLICIT NONE INTEGER KEEP(500), MPG, INFO(40), ICNTL(40) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 16 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 (ICNLT(9)=1) ' ENDIF ENDIF 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.1.2/src/cfac_root_parallel.F0000664000175000017500000001514013164366264017451 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_FACTO_ROOT( 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) USE CMUMPS_LR_STATS, ONLY: UPDATE_FLOPS_STATS_ROOT IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' TYPE ( CMUMPS_ROOT_STRUC ) :: root 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 IOLDPS INTEGER(8) :: IAPOS 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 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 UPDATE_FLOPS_STATS_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 UPDATE_FLOPS_STATS_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,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 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, DKEEP(6), KEEP(259), & 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.1.2/src/dlr_type.F0000664000175000017500000000422313164366264015460 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE DMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE DOUBLE PRECISION,POINTER,DIMENSION(:,:) :: Q,R INTEGER :: LRFORM,K,M,N,KSVD LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT,KEEP8,IS_FACTOR) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER(8) :: KEEP8(150) INTEGER :: MEM 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 KEEP8(70) = KEEP8(70) + int(MEM,8) IF (.NOT.IS_FACTOR) THEN KEEP8(71) = KEEP8(71) + int(MEM,8) ENDIF 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, NB_BLR, KEEP8, IS_FACTOR) INTEGER, INTENT(IN) :: NB_BLR TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: I IF (NB_BLR.GT.0) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=1, NB_BLR CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8, IS_FACTOR) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE DMUMPS_LR_TYPE MUMPS_5.1.2/src/zfac_mem_stack.F0000664000175000017500000005177113164366265016617 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, & IPOOL, LPOOL, LEAF, NSTK_S, & NBPROCFILS, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, & OPASSW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(40), KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, 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 ), & 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 NBPROCFILS( KEEP(28) ) 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, & NBROW_STACK, NBCOL_STACK, NELIM 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 COMPRESSCB, MUST_COMPACT_FACTORS LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE 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)),SLAVEF) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),SLAVEF) LREQCB = 0_8 INPLACE = .FALSE. COMPRESSCB= ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1) 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(*,*) "COMPRESSCB, NFRONT, NPIV, NASS, NSLAVES", & COMPRESSCB, 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 KEEP8(10) = KEEP8(10) + int(NPIV,8) * int(NFRONT,8) ELSE KEEP8(10) = KEEP8(10) + ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF KEEP8(10) = KEEP8(10) + int(NBROW,8) * int(NPIV,8) 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 ) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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)),SLAVEF) 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, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), SLAVEF ) 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 ), COMPRESSCB, & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) .EQ. MYID ) THEN LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_SEND = 0 IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NBROW ELSE NBCOL_STACK = NBCOL ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBCOL_STACK = NBCOL LREQI = 6 + NBROW_STACK + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (COMPRESSCB) THEN LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 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, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .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 (COMPRESSCB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (COMPRESSCB) 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 ( 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 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, COMPRESSCB, & 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, COMPRESSCB ) 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 NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND 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 KEEP8(8)=KEEP8(8) + int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF 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) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_STACK MUMPS_5.1.2/src/cana_aux.F0000664000175000017500000034464613164366264015435 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_ANA_F(N, NZ8, IRN, ICN, LIW8, IKEEP, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id) USE CMUMPS_STRUC_DEF USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: IRN(NZ8) INTEGER, INTENT(IN) :: ICNTL(40) INTEGER, INTENT(INOUT) :: ICN(NZ8) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(INOUT) :: INFO(40), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) TYPE (CMUMPS_STRUC) :: id INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE :: 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(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS #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 PIV(N) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL LOGICAL IDENT,SPLITROOT 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 ALLOCATE( IW (LIW8), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIW8,INFO(2)) GOTO 90 ENDIF ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( IPE(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 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 (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN WRITE (MP,99999) N, NZ8, LIW8, INFO(1) J8 = min(10_8,NZ8) IF (LDIAG.EQ.4) J8 = NZ8 IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) 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 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, ICN, IW(1), LIW8, & IPE, 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, SIZE_SCHUR, FRERE, FILS) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif 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, ICN, IW(1), LIW8, & IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265)) DEALLOCATE(IPQ8) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif INFO(8) = symmetry IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .LE. 1 ) 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( N, KEEP(50), NSLAVES, IORD, & symmetry, 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 IF(KEEP(95) .EQ. 2 .AND. IORD .EQ. 0) THEN IF (PROK) WRITE(MP,*) & 'WARNING: CMUMPS_ANA_F AMD not available with ', & ' compressed ordering -> move to QAMD' IORD = 6 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(id%CNTL(4) .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,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) 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, ICN, PIV, & NCMP, IW(1), LIW8, IPE, PTRAR(1,2), IPQ8, & IWL1, FILS, IWFR8, & IERROR, KEEP, KEEP8, ICNTL) 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)=id%COLSCA(J) ENDDO DO J=1, N id%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, ICN, IW(1), LIW8, IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265)) DEALLOCATE(IPQ8) INFO(8) = symmetry 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 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 (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, IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR, 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) 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 IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, N, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, N, 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 CALL CMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS) CALL CMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW(1), & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW(1), & 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 (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(1), IWL1, IKEEP, & IKEEP(1,2), NCMPA, INFO, LP, LPOK) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW(1), IWL1, IKEEP, & IKEEP(1,2), NCMPA, INFO, LP, LPOK, KEEP(10)) 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) THEN CALL CMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS) CALL CMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .GE. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IWL1(1) = -1 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4(NCMP, NBBUCK, LIW8, IPE, & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP, PARENT) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE, & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ, FRERE, PARENT) 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 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 TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_QAMD(TOTEL,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE, IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT) DEALLOCATE(WTEMP) ELSE CALL MUMPS_ANA_H(NCMP, LIW8, IPE, IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL CMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV,IKEEP(1,1),IKEEP(1,2)) 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 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF OPTIONS_METIS(1) = 0 #else OPT_METIS_SIZE = 40 OPT_METIS_SIZE = OPT_METIS_SIZE + 60 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF CALL METIS_SETDEFAULTOPTIONS(OPTIONS_METIS) OPTIONS_METIS(18) = 1 #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(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK, KEEP(10) ) 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(1), NUMFLAG, & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW(1), NUMFLAG, & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10)) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF #else ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW(1),FRERE(1), & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW(1),FRERE(1), & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10) ) 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 DEALLOCATE (OPTIONS_METIS) IF ( COMPRESS_SCHUR ) THEN CALL CMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP(1,1),IKEEP(1,2), & LISTVAR_SCHUR, SIZE_SCHUR, FILS) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL CMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV,IKEEP(1,1),IKEEP(1,2)) 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) & ) THEN DO K=1,N PTRAR(K,1) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (PTRAR(IKEEP(K,1),1).EQ.1) THEN GOTO 40 ELSE PTRAR(IKEEP(K,1),1) = 1 ENDIF ENDDO ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1) THEN IF ((KEEP(106)==1).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, ICN, IW(1), LIW8, & IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265)) DEALLOCATE(IPQ8) INFO(8) = symmetry ENDIF COMPRESS = 0 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. CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, LIW8, IPE, IWFR8, PTRAR(1,2), IW, & IWL1, WTEMP(N+1), & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, & PTRAR(1,3),IKEEP(1,1), LISTVAR_SCHUR, ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ELSE CALL CMUMPS_ANA_J(N, NZ8, IRN, ICN, IKEEP, IW(1), & LIW8, IPE, & 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, IW, LIW8, IWFR8, IKEEP, & IKEEP(1,2), 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, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else IF (allocated(IPE)) DEALLOCATE(IPE) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF CALL CMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, PTRAR, INFO(6), FILS, FRERE, & 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) 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(IKEEP(1,2), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP(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 .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) 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).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 CALL CMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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 CALL CMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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,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 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(IW)) DEALLOCATE(IW) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 9X, I8, I11, I12, I14) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I7, I12, I7, I12, I7)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) END SUBROUTINE CMUMPS_ANA_F 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) 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 #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,INT,NR1 #else INTEGER DADI LOGICAL AMALG_TO_father_OK #endif AMALG_COUNT = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 NODE(I) = 1 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE 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 NODE(IF) = NODE(IF)+1 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 #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 AMALG_TO_father_OK = .TRUE. 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 INT = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT) = -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, MAXFAC, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER NSTEPS,MAXNPIV INTEGER MAXFR, MAXELIM, K50, MAXFAC INTEGER K5,K6,PANEL_SIZE,K253 INTEGER NE(NSTEPS), ND(NSTEPS) INTEGER ITREE, NFR, NELIM INTEGER LKJIB LKJIB = max(K5,K6) MAXFR = 0 MAXFAC = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 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 MAXFAC = max(MAXFAC, (2*NFR - NELIM)*NELIM ) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE MAXFAC = max(MAXFAC, NFR * NELIM) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF 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_ANA_O( N, NZ, MTRANS, PERM, & id, ICNTL, INFO) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(N) INTEGER, INTENT(INOUT) :: MTRANS INTEGER, INTENT(IN) :: ICNTL(40) INTEGER, INTENT(INOUT) :: INFO(40) 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 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)) IF (PROK) WRITE(MPRINT,101) 101 FORMAT(/'****** Preprocessing of original matrix '/) K50 = id%KEEP(50) SCALINGLOC = .FALSE. IF(id%KEEP(52) .EQ. -2) THEN IF(.not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(id%KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF(K50 .NE. 2) THEN IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' ENDIF ENDIF IF(.not.associated(id%A)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF 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 MTRANSLOC = 5 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 => id%IS1(N+1:2*N) STR_KER => id%IS1(2*N+1:3*N) CALL CMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(2) 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 id%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 ) GOTO 410 ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (2*N+1)*id%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 ) GOTO 430 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 = id%IRN(K) J = id%JCN(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 = id%IRN(K) J = id%JCN(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(id%A)) THEN IF(abs(id%A(K)) .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 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 = id%IRN(K) J = id%JCN(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(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF K = 1_8 THEMIN = ZERO DO IF(THEMIN .NE. ZERO) EXIT THEMIN = abs(id%A(K)) K = K+1_8 ENDDO THEMAX = THEMIN DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(id%A(K)) .GT. THEMAX) THEN THEMAX = abs(id%A(K)) ELSE IF(abs(id%A(K)) .LT. THEMIN & .AND. abs(id%A(K)).GT. ZERO) THEN THEMIN = abs(id%A(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(id%A(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 CNTL64(2) = (log(THEMAX/THEMIN))*(real(N)) & - log(THEMIN) + ONE ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => id%IS1(3*N+1:4*N) IF(MTRANSLOC.NE.1) THEN CALL CMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM,IPQ8(1)) ELSE CALL CMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM) 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, 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 = id%JCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 id%JCN(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(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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( id%ROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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 id%KEEP(52) = -2 id%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) id%ROWSCA(J) = exp(S2(RSPOS+J8)) IF(id%ROWSCA(J) .EQ. ZERO) THEN id%ROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN id%COLSCA(J)= exp(S2(CSPOS+J8)) IF(id%COLSCA(J) .EQ. ZERO) THEN id%COLSCA(J) = ONE ENDIF ELSE id%COLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(id%COLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN id%COLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(id%COLSCA)) DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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( id%ROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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 id%KEEP(52) = -2 id%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 id%ROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(id%ROWSCA(J) .EQ. ZERO) THEN id%ROWSCA(J) = ONE ENDIF id%COLSCA(J)= id%ROWSCA(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) id%ROWSCA(I) = ONE / COLNORM id%COLSCA(I) = id%ROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. id%KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. id%KEEP(95) .EQ. 0) THEN MTRANS = 0 id%KEEP(95) = 1 GOTO 390 ELSE IF(id%KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN id%KEEP(95) = 3 ELSE id%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 => id%IS1(2*N+1:3*N) FLAG => id%IS1(3*N+1:4*N) PIV_OUT => id%IS1(4*N+1:5*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, & 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( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 & ) THEN IDENT = .TRUE. id%KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF id%KEEP(93) = INFO_SYM_MWM(4) id%KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN id%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 SUBROUTINE CMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL ) IMPLICIT NONE INTEGER COMM, MYID, KEEP(500), INFO(40), ICNTL(40), INFOG(40) 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), 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) Storage of factors (REAL, estimated) =',I16/ & ' -- (4) Storage of factors (INT , 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/ & 'Percentage of memory relaxation (effective) =',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, 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 ) 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 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)), & 1_8) IF (KEEP(53).NE.0) THEN MAX_CUT = NFRONT K79 = 121_8*121_8 ELSE K79 = min(2000_8*2000_8,K79) 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 ) 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 ) 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 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_SON, NPIV_FATH 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 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 DO WHILE( IN > 0 ) IN = FILS( IN ) NPIV = NPIV + 1 END DO 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)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375)) 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 NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 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 IN_SON = INODE DO I = 1, NPIV_SON - 1 IN_SON = FILS( IN_SON ) END DO 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 ) 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 ) 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) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) 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 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) 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 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE 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 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 ((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 ELSE symmetry = 100 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 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_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(40) 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).GE.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, 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(INOUT) :: INFO(40) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN 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) IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO 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 DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE CMUMPS_SORT_PERM SUBROUTINE CMUMPS_ANA_N_PAR( id, PTRAR ) USE CMUMPS_STRUC_DEF IMPLICIT NONE include 'mpif.h' TYPE(CMUMPS_STRUC), INTENT(IN), TARGET :: id INTEGER(8), INTENT(OUT), TARGET :: PTRAR(id%N,2) INTEGER :: IERR 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(1:id%N,2) allocate(IWORK2(id%N)) IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => PTRAR(1:id%N,1) IWORK2 => PTRAR(1:id%N,2) 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,1), id%N, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), id%N, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR, 2*id%N, MPI_INTEGER8, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE CMUMPS_ANA_N_PAR SUBROUTINE CMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(40),INFOG(40),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) REAL PEAK CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & ) 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.1.2/src/mumps_metis64.c0000664000175000017500000001064713164366240016410 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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; } #endif MUMPS_5.1.2/src/cmumps_load.F0000664000175000017500000065451413164366265016160 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) INTEGER, SAVE, PRIVATE :: NB_LEVEL2 LOGICAL, PRIVATE :: AMI_CHOSEN,IS_DISPLAYED #endif #endif #if ! defined(OLD_LOAD_MECHANISM) DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM #else DOUBLE PRECISION, SAVE, PRIVATE :: LAST_LOAD_SENT, & DM_LAST_MEM_SENT #endif 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 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, K66, & K375, MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER, INTENT(IN) :: K64, K66, K375 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(K66), 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 (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(40), & 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .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(40), & 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .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(40), & 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(40) 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 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 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 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)) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE TYPE(CMUMPS_STRUC), TARGET :: id INTEGER(8), intent(in) :: MEMORY_MD_ARG INTEGER(8), intent(in) :: MAXS INTEGER K34_LOC,K35_LOC INTEGER allocok, IERR, i, BUF_LOAD_SIZE DOUBLE PRECISION :: MAX_SBTR DOUBLE PRECISION ZERO DOUBLE PRECISION MEMORY_SENT PARAMETER( ZERO=0.0d0 ) DOUBLE PRECISION SIZE_REAL(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 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 ) 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 #if ! defined(OLD_LOAD_MECHANISM) 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 #endif CHECK_MEM=0_8 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) NB_LEVEL2=0 AMI_CHOSEN=.FALSE. IS_DISPLAYED=.FALSE. #endif #endif 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) 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) 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) SBTR_PEAK_ARRAY=dble(0) IF (allocated(SBTR_CUR_ARRAY)) DEALLOCATE(SBTR_CUR_ARRAY) ALLOCATE(SBTR_CUR_ARRAY(id%NBSA_LOCAL),stat=allocok) 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_REAL(1),SIZE_REAL(2),K35_LOC) K35 = K35_LOC BUF_LOAD_SIZE = K34_LOC * 2 * ( NPROCS - 1 ) + & NPROCS * ( K35_LOC + K34_LOC ) IF (BDC_MEM) THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35_LOC END IF IF (BDC_SBTR)THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35_LOC 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 defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MYID ) = COST_SUBTREE LAST_LOAD_SENT = ZERO #endif IF ( BDC_MEM ) THEN DO i = 0, NPROCS - 1 DM_MEM( i )=ZERO END DO #if defined(OLD_LOAD_MECHANISM) DM_LAST_MEM_SENT=ZERO #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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 TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL CMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE DOUBLE PRECISION INC_LOAD INTEGER KEEP(500) INTEGER(8) KEEP8(150) LOGICAL PROCESS_BANDE 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 ! defined(OLD_LOAD_MECHANISM) IF ( PROCESS_BANDE ) THEN RETURN ENDIF #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 #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = DELTA_LOAD + & (INC_LOAD-REMOVE_NODE_COST) GOTO 888 #else GOTO 888 #endif ELSE #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = DELTA_LOAD - & (REMOVE_NODE_COST-INC_LOAD) GOTO 888 #else GOTO 888 #endif ENDIF ENDIF GOTO 333 ENDIF #if ! defined(OLD_LOAD_MECHANISM) 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 #else 888 CONTINUE IF ( abs( LOAD_FLOPS ( MYID ) - & LAST_LOAD_SENT ).GT.MIN_DIFF)THEN IERR = 0 SEND_LOAD = LOAD_FLOPS( MYID ) IF ( BDC_MEM ) THEN SEND_MEM = DM_MEM(MYID) ELSE SEND_MEM = ZERO END IF #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_UPDATE",IERR CALL MUMPS_ABORT() ENDIF IF ( IERR .EQ. 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = ZERO IF (BDC_MEM) DELTA_MEM = ZERO #else LAST_LOAD_SENT = LOAD_FLOPS( MYID ) IF ( BDC_MEM ) DM_LAST_MEM_SENT = DM_MEM( MYID ) #endif END IF 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 #if defined(OLD_LOAD_MECHANISM) DOUBLE PRECISION TMP_MEM #endif IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN PROCESS_BANDE=PROCESS_BANDE_ARG INC_MEM = INC_MEM_ARG #if ! defined(OLD_LOAD_MECHANISM) 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 #endif #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) IF(PROCESS_BANDE)THEN PROCESS_BANDE=.FALSE. NB_LEVEL2=NB_LEVEL2-1 IF(NB_LEVEL2.LT.0)THEN WRITE(*,*)MYID,': problem with NB_LEVEL2' ELSEIF(NB_LEVEL2.EQ.0)THEN IF(IS_DISPLAYED)THEN IS_DISPLAYED=.FALSE. ENDIF AMI_CHOSEN=.FALSE. ENDIF ENDIF IF((KEEP(73).EQ.0).AND.(NB_LEVEL2.NE.0) & .AND.(.NOT.IS_DISPLAYED))THEN IS_DISPLAYED=.TRUE. ENDIF #endif #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 ! defined(OLD_LOAD_MECHANISM) IF (PROCESS_BANDE) THEN RETURN ENDIF #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 defined(OLD_LOAD_MECHANISM) IF(KEEP_LOAD(201).EQ.0)THEN DM_MEM( MYID ) = dble(CHECK_MEM) - DM_SUMLU ELSE DM_MEM( MYID ) = dble(CHECK_MEM) ENDIF TMP_MEM = DM_MEM(MYID) #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 ! defined(OLD_LOAD_MECHANISM) 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 #else IF(BDC_M2_MEM.AND.REMOVE_NODE_FLAG_MEM)THEN IF(INC_MEM.NE.REMOVE_NODE_COST_MEM)THEN IF(INC_MEM.EQ.REMOVE_NODE_COST_MEM)THEN GOTO 333 ELSEIF(INC_MEM.LT.REMOVE_NODE_COST_MEM)THEN GOTO 333 ENDIF ENDIF ENDIF IF ((KEEP(48).NE.5).OR. & ((KEEP(48).EQ.5).AND. & (abs(TMP_MEM-DM_LAST_MEM_SENT).GE. & 0.2d0*dble(LRLUS))))THEN IF ( abs( TMP_MEM-DM_LAST_MEM_SENT) > & DM_THRES_MEM ) THEN IERR = 0 SEND_MEM = TMP_MEM #endif 111 CONTINUE CALL CMUMPS_BUF_SEND_UPDATE_LOAD( & BDC_SBTR, & BDC_MEM,BDC_MD, COMM_LD, & NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & DELTA_LOAD, #else & LOAD_FLOPS( MYID ), #endif & SEND_MEM,SBTR_TMP, & DM_SUMLU, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_MEM_UPDATE",IERR CALL MUMPS_ABORT() ENDIF IF ( IERR .EQ. 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = ZERO DELTA_MEM = ZERO #else LAST_LOAD_SENT = LOAD_FLOPS ( MYID ) DM_LAST_MEM_SENT = TMP_MEM #endif END IF 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 ) #if ! defined(OLD_LOAD_MECHANISM) DEALLOCATE(FUTURE_NIV2) #endif 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 IERR, MSGTAG, MSGLEN, MSGSOU,COMM INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL FLAG 10 CONTINUE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) 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) 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) 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 ) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE INTEGER MSGSOU, LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INCLUDE 'mpif.h' INTEGER POSITION, IERR, WHAT, NSLAVES, i 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 ) IF ( WHAT == 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) #else #endif CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR ) #if ! defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED #else LOAD_FLOPS( MSGSOU ) = LOAD_RECEIVED #endif IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR ) #if ! defined(OLD_LOAD_MECHANISM) DM_MEM(MSGSOU) = DM_MEM(MSGSOU) + LOAD_RECEIVED #else DM_MEM(MSGSOU) = LOAD_RECEIVED #endif 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 ) 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 ) 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) WRITE(*,*)MYID,':Receiving M2A from',MSGSOU i=1 DO WHILE ((i.LE.NSLAVES).AND.(LIST_SLAVES(i).NE.MYID)) i=i+1 ENDDO IF(i.LT.(NSLAVES+1))THEN NB_LEVEL2=NB_LEVEL2+1 WRITE(*,*)MYID,':NB_LEVEL2=',NB_LEVEL2 AMI_CHOSEN=.TRUE. IF(KEEP_LOAD(73).EQ.1)THEN IF(.NOT.IS_DISPLAYED)THEN WRITE(*,*)MYID,': Begin of Incoherent state (2) at time=', & MPI_WTIME()-TIME_REF IS_DISPLAYED=.TRUE. ENDIF ENDIF ENDIF IF(KEEP_LOAD(73).EQ.1) GOTO 344 #endif #endif DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif LOAD_FLOPS(LIST_SLAVES(i)) = & LOAD_FLOPS(LIST_SLAVES(i)) + & LOAD_INCR(i) #if defined(OLD_LOAD_MECHANISM) END IF #endif END DO IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif 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))) #if defined(OLD_LOAD_MECHANISM) END IF #endif 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) 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 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) 344 CONTINUE #endif #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 ) 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 ) SBTR_MEM(MSGSOU)=SBTR_MEM(MSGSOU)+LOAD_RECEIVED #if ! defined(OLD_LOAD_MECHANISM) 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 ) MD_MEM(MSGSOU)=999999999_8 TAB_MAXS(MSGSOU)=TAB_MAXS(MSGSOU)+int(SURF,8) ENDIF #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 ) 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR ) IF( & MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE_RECEIVED)), & NPROCS).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 ) 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 ) 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 ) IF(BDC_MD)THEN #if ! defined(OLD_LOAD_MECHANISM) DM_MEM(MYID)=DM_MEM(MYID)+LOAD_RECEIVED #else DM_MEM(MYID)=LOAD_RECEIVED #endif 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 ) #if ! defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED #else LOAD_FLOPS( MSGSOU ) = LOAD_RECEIVED #endif 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif MD_MEM(LIST_SLAVES(i)) = & MD_MEM(LIST_SLAVES(i)) + & int(LOAD_INCR(i),8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(LIST_SLAVES(i)+1).EQ.0)THEN MD_MEM(LIST_SLAVES(i))=999999999_8 ENDIF #endif #if defined(OLD_LOAD_MECHANISM) END IF #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 ) MD_MEM(MSGSOU)=MD_MEM(MSGSOU)+int(LOAD_RECEIVED,8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(MSGSOU+1).EQ.0)THEN MD_MEM(MSGSOU)=999999999_8 ENDIF #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 ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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 #if ! defined(OLD_LOAD_MECHANISM) #if ! defined(IBC_TEST) 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) GOTO 112 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 #endif #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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif 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 #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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)), SLAVEF ) 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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) GOTO 111 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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)), NPROCS) & ) THEN RETURN ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE_LOAD(STEP_LOAD(INODE)),NPROCS))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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0), & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0), MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 112 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 CONTINUE 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) IF (WLOAD(i) < -0.5d0 ) THEN IF((MP.GT.0).AND.(LP.GE.2))THEN WRITE(MP,*)MYID,': Warning: negative load ', & WLOAD(i) ENDIF ENDIF 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)), & SLAVEF))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)), NPROCS ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL 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 #if ! defined(OLD_LOAD_MECHANISM) TO_BE_SENT=DELTA_LOAD-COST DELTA_LOAD=dble(0) #else TO_BE_SENT=LAST_LOAD_SENT-COST LAST_LOAD_SENT=LAST_LOAD_SENT-COST #endif 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 #if ! defined(OLD_LOAD_MECHANISM) DELTA_MEM=DELTA_MEM+TMP_M2 TO_BE_SENT=DELTA_MEM #else TO_BE_SENT=DM_LAST_MEM_SENT+TMP_M2 DM_LAST_MEM_SENT=DM_LAST_MEM_SENT+TMP_M2 #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, & TO_BE_SENT, & MYID, KEEP_LOAD, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF 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 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)), & SLAVEF)) THEN RETURN ENDIF FATHER=MUMPS_PROCNODE(PROCNODE(STEP(FATHER_NODE)),SLAVEF) 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)), & NPROCS).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) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_UPPER_PREDICT", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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)), NPROCS ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error 2 in CMUMPS_LOAD_SEND_MD_INFO", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif DO i = 1, NP_TO_UPDATE MD_MEM(P_TO_UPDATE(i))=MD_MEM(P_TO_UPDATE(i))+ & int(DELTA_MD( i ),8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(P_TO_UPDATE(i)+1).EQ.0)THEN MD_MEM(P_TO_UPDATE(i))=999999999_8 ENDIF #endif ENDDO #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif DEALLOCATE(DELTA_MD,P_TO_UPDATE,IPROC2POSINDELTAMD) 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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)),NPROCS).EQ.MYID)THEN IF(INODE.EQ.KEEP_LOAD(38))THEN GOTO 666 #if ! defined(OLD_LOAD_MECHANISM) ELSE IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': i did not find ',SON CALL MUMPS_ABORT() ENDIF GOTO 666 #endif 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 defined(NOT_ATM_POOL_SPECIAL) DOUBLE PRECISION TMP #endif IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0) & .AND.(INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF #if defined(NOT_ATM_POOL_SPECIAL) IF((INODE.LT.0).OR.(INODE.GT.N_LOAD))THEN MAX_MEM=huge(MAX_MEM) DO i=0,NPROCS-1 TMP=dble(TAB_MAXS(i))-(DM_MEM(i)+LU_USAGE(i)) IF(BDC_SBTR)THEN TMP=TMP-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF MAX_MEM=min(MAX_MEM,TMP) ENDDO RETURN ENDIF #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)), & NPROCS).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)), & NPROCS).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 ! defined(OLD_LOAD_MECHANISM) 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 #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)),NPROCS).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 #if defined(NOT_ATM_POOL_SPECIAL) IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N_LOAD ) THEN NODE = POOL(LPOOL-2-J) - N_LOAD ELSE NODE = POOL(LPOOL-2-J) ENDIF #else NODE=POOL(LPOOL-2-J) #endif 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)),NPROCS).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))), & NPROCS)) 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 MUMPS_5.1.2/src/cfac_par_m.F0000664000175000017500000007724713164366265015731 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS,ND,FILS,STEP, & FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, NTOTPV, NMAXNPIV, PTRIST, PTRAST, & PIMASTER, PAMASTER, PTRARW, PTRAIW, & ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, & LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, NSTEPS, 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_LR 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER N,NTOTPV,MAXFRT,LIW, LPTRAR, NMAXNPIV, & NSTEPS, INFO(40) 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(40) 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)), NBPROCFILS(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 MAXFRW, NPVW, NOFFW, NELVAW, COMP, & JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' DOUBLE PRECISION OPASSW, OPELIW ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL PTRIST(1:KEEP(28))=0 PTLUST(1:KEEP(28))=0 PTRAST(1:KEEP(28))=0_8 PTRFAC(1:KEEP(28))=-99999_8 PIMASTER(1:KEEP(28))=-99999_8 PAMASTER(1:KEEP(28))=-99999_8 MP = ICNTL(2) LP = ICNTL(1) MAXFRW = 0 NPVW = 0 NOFFW = 0 NELVAW = 0 COMP = 0 OPASSW = DZERO OPELIW = DZERO IWPOSCB = LIW 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, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 NBPROCFILS(1:KEEP(28)) = 0 #if ! defined(NO_XXNBPR) KEEP(121)=0 #endif IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL CMUMPS_ROOT_ALLOC_STATIC( & root, KEEP(38), N, IW, LIW, & A, LA, & FILS, MYID_NODES, 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 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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 (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)),SLAVEF) 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, NOFFW, NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ELSE CALL CMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, NOFFW, NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ( 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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,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, & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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,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, & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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 ( INFO(1) .LT. 0 ) GOTO 640 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTLUST(STEP(INODE))+XXNBPR) ) IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN #else IF ((NBPROCFILS(STEP(INODE)).GT.0).OR.(SON_LEVEL2)) THEN #endif 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, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NBPROCFILS, 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, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF 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, NOFFW, NPVW, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & ) ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL CMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFW, NPVW, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & ) 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,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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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 (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) 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),OPELIW,NELVAW,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, & LRLUS,IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, NBPROCFILS, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, OPASSW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) 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)),SLAVEF).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)),SLAVEF)) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, 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,SLAVEF, & 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) .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)))), & SLAVEF) 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( 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, & OPELIW ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & SLAVEF) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NPVW = NPVW + INFO(2) ELSE NPVW = NPVW + 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(70) = KEEP8(70) + ITMP8 KEEP8(71) = KEEP8(71) + 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 CALL MUMPS_SET_IERROR(LRHS_CNTR_MASTER_ROOT,INFO(2)) 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)) NPVW = NPVW + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & NFRONT8*NFRONT8 ) THEN POSFAC = POSFAC - NFRONT8*NFRONT8 LRLUS = LRLUS + NFRONT8*NFRONT8 LRLU = LRLUS + NFRONT8*NFRONT8 KEEP8(70) = KEEP8(70) + NFRONT8*NFRONT8 KEEP8(71) = KEEP8(71) + NFRONT8*NFRONT8 CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-NFRONT8*NFRONT8,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))),SLAVEF) & ) THEN MAXFRW = max ( MAXFRW, root%TOT_ROOT_SIZE) END IF END IF MAXFRT = MAXFRW NTOTPV = NPVW INFO(12) = NOFFW RINFO(2) = real(OPASSW) RINFO(3) = real(OPELIW) INFO(13) = NELVAW INFO(14) = COMP 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.1.2/src/mumps_io_thread.h0000664000175000017500000000622113164366240017051 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/src/smumps_ooc.F0000664000175000017500000036050213164366263016026 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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 #if ! defined (OOC_DEBUG) PTRFAC(STEP_OOC(INODE))=-777777_8 #endif 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 #if ! defined (OOC_DEBUG) PTRFAC(STEP_OOC(INODE))=-777777_8 #endif 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' 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))), & SLAVEF_OOC ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & SLAVEF_OOC ) 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)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),SLAVEF_OOC).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)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),SLAVEF_OOC).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) 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 #if ! defined(TEMP_VERSION_TO_FORCE_DATA_REINIT) & .OR. KEEP_OOC(50).NE.0 #endif & ) 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 #if ! defined(TEMP_VERSION_TO_FORCE_DATA_REINIT) & .OR. KEEP_OOC(50).NE.0 #endif & ) 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_STRUC_STORE_FILE_NAME' 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) & WRITE(ICNTL1,*) & 'PB allocation in SMUMPS_STRUC_STORE_FILE_NAME' 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) & WRITE(ICNTL1,*) & 'PB allocation in SMUMPS_OOC_OPEN_FILES_FOR_SOLVE' 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) 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.1.2/src/sbcast_int.F0000664000175000017500000000276113164366262015772 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/sfac_process_contrib_type1.F0000664000175000017500000001047013164366262021151 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) 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(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 COMPRESSCB 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) COMPRESSCB = (FLCONT.LT.0) IF (COMPRESSCB) 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) IF (IPTRLU.LT.0_8) WRITE(*,*) 'before alloc_cb:IPTRLU = ',IPTRLU CALL SMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, IFLAG, IERROR & ) IF (IPTRLU.LT.0_8) WRITE(*,*) 'after alloc_cb:IPTRLU = ',IPTRLU IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (COMPRESSCB) 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 (COMPRESSCB) 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 IF ( LREQCB .ne. 0_8 ) THEN IPOS_NODE = PAMASTER(STEP(FINODE))-1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + 1_8 + ISHIFT_PACKET), & SIZE_PACKET, MPI_REAL, COMM, IERR) END IF 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.1.2/src/zfac_asm.F0000664000175000017500000005710213164366265015426 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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(8) :: POSELT 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)) POSELT = PTRAST(STEP(INODE)) 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, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), & RHS_MUMPS) 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) IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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 INCLUDE 'mumps_headers.h' INTRINSIC real IOLDPS = PTRIST(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) 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(APOS+int(J-1,8)) = A( 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(K8) = A(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(APOS:APOS+int(NBCOLS-IDIAG-1,8))= & A(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(K8) = A(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 & ) 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 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.300 !$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)) & A(JJ2) = cmplx(VALSON(JJ1),kind=kind(A)) 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) 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) 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 :: 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)) A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = ZERO NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) 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 MUMPS_5.1.2/src/cana_aux_ELT.F0000664000175000017500000010673013164366264016127 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) 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(40) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(40), 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) 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, 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, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS 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 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF OPTIONS_METIS(1) = 0 #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 OPT_METIS_SIZE = OPT_METIS_SIZE + 60 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE RETURN ENDIF CALL METIS_SETDEFAULTOPTIONS(OPTIONS_METIS) OPTIONS_METIS(18) = 1 #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(1), #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG(1), #endif & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2(1), #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG(1), #endif & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), & LP, LPOK, KEEP(10) ) 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) #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), & KEEP(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 CALL CMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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 CALL CMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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, I8, 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(40) 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( 40 ) 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 TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), SLAVEF ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .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 ) IMPLICIT NONE INTEGER N, NELT, SLAVEF INTEGER PROCNODE( N ), ELTPROC( NELT ) INTEGER ELT, I, ITYPE, MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),SLAVEF) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),SLAVEF) ELSE IF (ITYPE.EQ.2) 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.1.2/src/cana_mtrans.F0000664000175000017500000007637413164366266016146 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/dfac_par_m.F0000664000175000017500000007735713164366264015733 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS,ND,FILS,STEP, & FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, NTOTPV, NMAXNPIV, PTRIST, PTRAST, & PIMASTER, PAMASTER, PTRARW, PTRAIW, & ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, & LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, NSTEPS, 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_LR 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER N,NTOTPV,MAXFRT,LIW, LPTRAR, NMAXNPIV, & NSTEPS, INFO(40) 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(40) 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)), NBPROCFILS(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 MAXFRW, NPVW, NOFFW, NELVAW, COMP, & JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' DOUBLE PRECISION OPASSW, OPELIW ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL PTRIST(1:KEEP(28))=0 PTLUST(1:KEEP(28))=0 PTRAST(1:KEEP(28))=0_8 PTRFAC(1:KEEP(28))=-99999_8 PIMASTER(1:KEEP(28))=-99999_8 PAMASTER(1:KEEP(28))=-99999_8 MP = ICNTL(2) LP = ICNTL(1) MAXFRW = 0 NPVW = 0 NOFFW = 0 NELVAW = 0 COMP = 0 OPASSW = DZERO OPELIW = DZERO IWPOSCB = LIW 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, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 NBPROCFILS(1:KEEP(28)) = 0 #if ! defined(NO_XXNBPR) KEEP(121)=0 #endif IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL DMUMPS_ROOT_ALLOC_STATIC( & root, KEEP(38), N, IW, LIW, & A, LA, & FILS, MYID_NODES, 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 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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 (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)),SLAVEF) 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, NOFFW, NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ELSE CALL DMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, NOFFW, NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ( 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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,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, & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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,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, & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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 ( INFO(1) .LT. 0 ) GOTO 640 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTLUST(STEP(INODE))+XXNBPR) ) IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN #else IF ((NBPROCFILS(STEP(INODE)).GT.0).OR.(SON_LEVEL2)) THEN #endif 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, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NBPROCFILS, 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, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF 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, NOFFW, NPVW, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & ) ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL DMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFW, NPVW, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & ) 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,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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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 (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) 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),OPELIW,NELVAW,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, & LRLUS,IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, NBPROCFILS, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, OPASSW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) 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)),SLAVEF).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)),SLAVEF)) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, 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,SLAVEF, & 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) .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)))), & SLAVEF) 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( 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, & OPELIW ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & SLAVEF) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NPVW = NPVW + INFO(2) ELSE NPVW = NPVW + 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(70) = KEEP8(70) + ITMP8 KEEP8(71) = KEEP8(71) + 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 CALL MUMPS_SET_IERROR(LRHS_CNTR_MASTER_ROOT,INFO(2)) 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)) NPVW = NPVW + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & NFRONT8*NFRONT8 ) THEN POSFAC = POSFAC - NFRONT8*NFRONT8 LRLUS = LRLUS + NFRONT8*NFRONT8 LRLU = LRLUS + NFRONT8*NFRONT8 KEEP8(70) = KEEP8(70) + NFRONT8*NFRONT8 KEEP8(71) = KEEP8(71) + NFRONT8*NFRONT8 CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-NFRONT8*NFRONT8,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))),SLAVEF) & ) THEN MAXFRW = max ( MAXFRW, root%TOT_ROOT_SIZE) END IF END IF MAXFRT = MAXFRW NTOTPV = NPVW INFO(12) = NOFFW RINFO(2) = dble(OPASSW) RINFO(3) = dble(OPELIW) INFO(13) = NELVAW INFO(14) = COMP 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.1.2/src/zsol_matvec.F0000664000175000017500000002401513164366266016167 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(out) :: 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.1.2/src/sfac_process_blocfacto.F0000664000175000017500000006560713164366262020337 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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 USE SMUMPS_LOAD USE SMUMPS_LR_STATS USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_DECOMPRESS_PANEL, & SMUMPS_COMPRESS_PANEL, & SMUMPS_BLR_UPDATE_TRAILING, & SMUMPS_FAKE_COMPRESS_CB USE SMUMPS_ANA_LR, ONLY : GET_CUT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mumps_headers.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ), 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), 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) :: LAELL INTEGER(8) :: POSELT INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, LPOS1, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTBL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED REAL ONE,ALPHA PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO INTEGER :: SEND_LR_INT, NELIM, NPARTSASS_MASTER, & CURRENT_BLR_PANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: SEND_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U 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 INTEGER T1, T2, COUNT_RATE REAL, DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL :: DYNAMIC_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE 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, CURRENT_BLR_PANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF IF ( SEND_LR ) THEN LAELL = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LAELL = int(NPIV,8) * int(NCOL,8) ENDIF IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLUS, IERROR) IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN LP=ICNTL(1) WRITE(LP,*) &" FAILURE, WORKSPACE TOO SMALL DURING SMUMPS_PROCESS_BLOCFACTO" ENDIF GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress SMUMPS_PROCESS_BLOCFACTO, LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR( LAELL-LRLUS, IERROR ) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN LP=ICNTL(1) WRITE(LP,*) &" FAILURE IN INTEGER ALLOCATION DURING SMUMPS_PROCESS_BLOCFACTO" ENDIF IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LAELL,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 ( SEND_LR ) 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))) ALLOCATE(BEGS_BLR_U(NB_BLR_U+2)) CALL SMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, KEEP(470), & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTRIST(STEP(INODE))+XXNBPR)) DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) #else DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) POSELT = PTRAST(STEP(INODE)) LCONT1 = IW( IOLDPS +KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 +KEEP(IXSZ)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) ELSE CALL SMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS) 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(IPOS), NCOL1, A(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(IPOS), NCOL1, A(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF (KEEP(486) .GT.0) THEN CALL SYSTEM_CLOCK(T1) ENDIF IF (DYNAMIC_ALLOC) THEN CALL strsm('L','L','N','N',NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, A(LPOS2), NCOL1) ELSE CALL strsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, A(LPOS2), NCOL1) ENDIF IF (KEEP(486) .GT.0) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_TRSM_TIME = ACC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (SEND_LR) THEN 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 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) MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) 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)) CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL & (A, LA, POSELT, IFLAG, IERROR, NCOL1, & BEGS_BLR_L, NB_BLR_L+1, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #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. & ( .NOT. SEND_LR .OR. (NPIV .EQ.0) .OR. & (KEEP(485).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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (SEND_LR) THEN IF (NELIM.GT.0) THEN IF (DYNAMIC_ALLOC) THEN LPOS1 = int(NPIV+1,8) CALL sgemm('N','N', NELIM,NROW1,NPIV, & ALPHA,DYN_BLOCFACTO(LPOS1),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ELSE LPOS1 = POSBLOCFACTO+int(NPIV,8) CALL sgemm('N','N', NELIM,NROW1,NPIV, & ALPHA,A(LPOS1),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, & BLR_L, NB_BLR_L+1, & BLR_U, NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, KEEP(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_UPDT_TIME = ACC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & 0, NPARTSCB, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, & .FALSE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L, CURRENT_BLR, 'V', NCOL1, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (KEEP(201).eq.1) 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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF ENDIF ELSE IF (DYNAMIC_ALLOC) THEN LPOS1 = int(NPIV+1,8) CALL sgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,DYN_BLOCFACTO(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ELSE LPOS1 = POSBLOCFACTO+int(NPIV,8) CALL sgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,A(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(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 (SEND_LR) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, .FALSE.) DEALLOCATE(BLR_U) CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8, .TRUE.) DEALLOCATE(BLR_L) ENDIF ENDIF IF (DYNAMIC_ALLOC) THEN DEALLOCATE(DYN_BLOCFACTO) DEALLOCATE(DYN_PIVINFO) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,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 (SEND_LR) 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 (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN CALL SMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_L, NB_BLR_L+1, & BEGS_BLR_U, NB_BLR_U+1, 1, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., NPIV1, KEEP(484)) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 (SEND_LR) 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 ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_L)) DEALLOCATE(BEGS_BLR_L) 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, K470, & 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, K470 CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(OUT) :: IERR, IFLAG, IERROR 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 :: LRFORM, K, M, N, KSVD 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, & LRFORM, 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & KSVD, 1, & MPI_INTEGER, COMM, IERR ) IF (DIR.EQ.'H') THEN IF (K470.EQ.1) THEN BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M ELSE BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + N ENDIF ELSE BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M ENDIF IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, KSVD, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (LRFORM .NE. BLR_U(I)%LRFORM) THEN WRITE(*,*) "Internal error 2 in ALLOC_LRB", & LRFORM, BLR_U(I)%LRFORM ENDIF 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.1.2/src/dstatic_ptr_m.F0000664000175000017500000000200313164366264016464 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zmumps_struc_def.F0000664000175000017500000000070613164366266017233 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/double_linked_list.F0000664000175000017500000010330313164366241017463 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE 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 IF ( .NOT. associated ( DLL ) ) THEN IDLL_LENGTH = -1 RETURN END IF LENGTH = 0 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 ( 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 IDLL MODULE 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) I = DDLL_LENGTH(DLL) ALLOCATE ( ARRAY ( I ), 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 DDLL MUMPS_5.1.2/src/zana_dist_m.F0000664000175000017500000007514413164366265016141 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, & NA, LNA, NE, DAD, ND, PROCNODE, SLAVEF, & NRLADU, NIRADU, NIRNEC, NRLNEC, & NRLNEC_ACTIVE, & NIRADU_OOC, NIRNEC_OOC, & MAXFR, OPSA, & KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND, SBUF_REC, 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 & ) IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER MYID, N, LNA, IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE 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), NA(LNA), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) 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, SBUF_REC 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, IPOOL, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR LOGICAL OUTER_SENDS_FR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER SBUFR, SBUFS INTEGER BLOCKING_RHS INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, NBROOT, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB, & LKJIBT, NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL COMPRESSCB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART 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 INTEGER MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_MAX_SURFCB_NBROWS, MUMPS_BLOC2_GET_NSLAVESMAX 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 COMPRESSCB=( 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), IPOOL(NSTEPS), & LSTKI(NSTEPS) , stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 4*NSTEPS RETURN endif LKJIB = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0) IF ( OUTER_SENDS_FR ) THEN LKJIB = max(LKJIB, KEEP(420)) ENDIF IF ( KEEP(486).NE.0 ) THEN LKJIB = max(LKJIB,KEEP(488)) ENDIF TNSTK = NE LEAF = NA(1)+1 IPOOL(1:LEAF-1) = NA(3:3+LEAF-2) NBROOT = NA(2) #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 = 0_8 ISTKI = 0 ISTKI_OOC = 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 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 NRLNEC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 ITOP = 0 MAXTEMPCB = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS = 1 SBUFR_CB = 1_8 SBUFR = 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 IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),SLAVEF) & .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 WRITE(MYID+6,*) ' ERROR 1 in ZMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() 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)),SLAVEF) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),SLAVEF) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & SLAVEF) 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. COMPRESSCB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 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 & ) 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 NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & int(LOCAL_M,8)*int(LOCAL_N,8)) NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) 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)), SLAVEF)) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) 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 = max(SBUFS, NFR*LKJIB+LKJIB+4) ELSE SBUFS = max(SBUFS, NELIM*LKJIB+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR = max(SBUFR, NFR*LKJIB+LKJIB+4) else SBUFR = max( SBUFR, NELIM*LKJIB+NELIM+6 ) IF (KEEP(50).EQ.1) THEN LKJIBT = LKJIB ELSE LKJIBT = min( NELIM, LKJIB * 2 ) ENDIF SBUFS = max(SBUFS, & LKJIBT*NBROWMAX+6) SBUFR = max( SBUFR, NBROWMAX*LKJIBT+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 SIZECBI = 2* NCB + 6 + 3 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 MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECBI = NCB + 5 + 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) NRLADU = NRLADU + NRLADU_CURRENT ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) NRLADU = NRLADU + NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECBI = 4 + NBROWMAX + NCB 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 (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 (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 = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) ENDIF 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 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)),SLAVEF) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),SLAVEF) 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 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)), & SLAVEF) .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 NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF 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)),SLAVEF) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)),SLAVEF).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) ELSE NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) ENDIF 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) 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) 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. COMPRESSCB)) 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 * NFR + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.COMPRESSCB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN SIZECBI = 2+ XSIZE_IC ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) 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)) SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) SIZECBI = 0 SIZECB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE 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 SIZECBI = NCB + 5 + SLAVEF - 1 + XSIZE_IC SIZECB = 0_8 ELSE IF (UPDATE) THEN SIZECBI = NFR + 6 + SLAVEF - 1 + XSIZE_IC IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 SIZECBI = 0 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (COMPRESSCB) 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 = NCB + 5 + SLAVEF - 1 + XSIZE_IC ELSE SIZECB = SIZECB_SLAVE SIZECBI = 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) ) 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 BLOCKING_RHS = KEEP(84) IF (KEEP(84).EQ.0) BLOCKING_RHS=1 NRLNEC = max(NRLNEC, & NRLADU+int(4*KEEP(127)*abs(BLOCKING_RHS),8)) IF (BLOCKING_RHS .LT. 0) THEN BLOCKING_RHS = - 2 * BLOCKING_RHS ENDIF NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(4*KEEP(127)*BLOCKING_RHS,8)) SBUF_RECOLD = max(int(SBUFR,8),SBUFR_CB) SBUF_RECOLD = max(SBUF_RECOLD, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC = max(SBUFR, int(min(100000_8,SBUFR_CB))) SBUF_REC = SBUF_REC + 17 SBUF_REC = SBUF_REC + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND = max(SBUFS, int(min(100000_8,SBUFR_CB))) SBUF_SEND = SBUF_SEND + 17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC = SBUF_REC+KEEP(108)+1 SBUF_SEND = SBUF_SEND+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC = 1 SBUF_SEND= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, IPOOL, & LSTKI ) OPS_SUBTREE = dble(OPS_SBTR_LOC) OPSA = dble(OPSA_LOC) KEEP(66) = int(OPSA_LOC/1000000.d0) RETURN END SUBROUTINE ZMUMPS_ANA_DISTM MUMPS_5.1.2/src/dmumps_load.F0000664000175000017500000065451413164366264016160 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) INTEGER, SAVE, PRIVATE :: NB_LEVEL2 LOGICAL, PRIVATE :: AMI_CHOSEN,IS_DISPLAYED #endif #endif #if ! defined(OLD_LOAD_MECHANISM) DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM #else DOUBLE PRECISION, SAVE, PRIVATE :: LAST_LOAD_SENT, & DM_LAST_MEM_SENT #endif 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 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, K66, & K375, MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER, INTENT(IN) :: K64, K66, K375 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(K66), 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 (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(40), & 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .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(40), & 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .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(40), & 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(40) 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 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 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 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)) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE TYPE(DMUMPS_STRUC), TARGET :: id INTEGER(8), intent(in) :: MEMORY_MD_ARG INTEGER(8), intent(in) :: MAXS INTEGER K34_LOC,K35_LOC INTEGER allocok, IERR, i, BUF_LOAD_SIZE DOUBLE PRECISION :: MAX_SBTR DOUBLE PRECISION ZERO DOUBLE PRECISION MEMORY_SENT PARAMETER( ZERO=0.0d0 ) DOUBLE PRECISION SIZE_REAL(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 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 ) 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 #if ! defined(OLD_LOAD_MECHANISM) 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 #endif CHECK_MEM=0_8 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) NB_LEVEL2=0 AMI_CHOSEN=.FALSE. IS_DISPLAYED=.FALSE. #endif #endif 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) 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) 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) SBTR_PEAK_ARRAY=dble(0) IF (allocated(SBTR_CUR_ARRAY)) DEALLOCATE(SBTR_CUR_ARRAY) ALLOCATE(SBTR_CUR_ARRAY(id%NBSA_LOCAL),stat=allocok) 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_REAL(1),SIZE_REAL(2),K35_LOC) K35 = K35_LOC BUF_LOAD_SIZE = K34_LOC * 2 * ( NPROCS - 1 ) + & NPROCS * ( K35_LOC + K34_LOC ) IF (BDC_MEM) THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35_LOC END IF IF (BDC_SBTR)THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35_LOC 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 defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MYID ) = COST_SUBTREE LAST_LOAD_SENT = ZERO #endif IF ( BDC_MEM ) THEN DO i = 0, NPROCS - 1 DM_MEM( i )=ZERO END DO #if defined(OLD_LOAD_MECHANISM) DM_LAST_MEM_SENT=ZERO #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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 TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL DMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE DOUBLE PRECISION INC_LOAD INTEGER KEEP(500) INTEGER(8) KEEP8(150) LOGICAL PROCESS_BANDE 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 ! defined(OLD_LOAD_MECHANISM) IF ( PROCESS_BANDE ) THEN RETURN ENDIF #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 #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = DELTA_LOAD + & (INC_LOAD-REMOVE_NODE_COST) GOTO 888 #else GOTO 888 #endif ELSE #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = DELTA_LOAD - & (REMOVE_NODE_COST-INC_LOAD) GOTO 888 #else GOTO 888 #endif ENDIF ENDIF GOTO 333 ENDIF #if ! defined(OLD_LOAD_MECHANISM) 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 #else 888 CONTINUE IF ( abs( LOAD_FLOPS ( MYID ) - & LAST_LOAD_SENT ).GT.MIN_DIFF)THEN IERR = 0 SEND_LOAD = LOAD_FLOPS( MYID ) IF ( BDC_MEM ) THEN SEND_MEM = DM_MEM(MYID) ELSE SEND_MEM = ZERO END IF #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_UPDATE",IERR CALL MUMPS_ABORT() ENDIF IF ( IERR .EQ. 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = ZERO IF (BDC_MEM) DELTA_MEM = ZERO #else LAST_LOAD_SENT = LOAD_FLOPS( MYID ) IF ( BDC_MEM ) DM_LAST_MEM_SENT = DM_MEM( MYID ) #endif END IF 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 #if defined(OLD_LOAD_MECHANISM) DOUBLE PRECISION TMP_MEM #endif IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN PROCESS_BANDE=PROCESS_BANDE_ARG INC_MEM = INC_MEM_ARG #if ! defined(OLD_LOAD_MECHANISM) 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 #endif #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) IF(PROCESS_BANDE)THEN PROCESS_BANDE=.FALSE. NB_LEVEL2=NB_LEVEL2-1 IF(NB_LEVEL2.LT.0)THEN WRITE(*,*)MYID,': problem with NB_LEVEL2' ELSEIF(NB_LEVEL2.EQ.0)THEN IF(IS_DISPLAYED)THEN IS_DISPLAYED=.FALSE. ENDIF AMI_CHOSEN=.FALSE. ENDIF ENDIF IF((KEEP(73).EQ.0).AND.(NB_LEVEL2.NE.0) & .AND.(.NOT.IS_DISPLAYED))THEN IS_DISPLAYED=.TRUE. ENDIF #endif #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 ! defined(OLD_LOAD_MECHANISM) IF (PROCESS_BANDE) THEN RETURN ENDIF #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 defined(OLD_LOAD_MECHANISM) IF(KEEP_LOAD(201).EQ.0)THEN DM_MEM( MYID ) = dble(CHECK_MEM) - DM_SUMLU ELSE DM_MEM( MYID ) = dble(CHECK_MEM) ENDIF TMP_MEM = DM_MEM(MYID) #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 ! defined(OLD_LOAD_MECHANISM) 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 #else IF(BDC_M2_MEM.AND.REMOVE_NODE_FLAG_MEM)THEN IF(INC_MEM.NE.REMOVE_NODE_COST_MEM)THEN IF(INC_MEM.EQ.REMOVE_NODE_COST_MEM)THEN GOTO 333 ELSEIF(INC_MEM.LT.REMOVE_NODE_COST_MEM)THEN GOTO 333 ENDIF ENDIF ENDIF IF ((KEEP(48).NE.5).OR. & ((KEEP(48).EQ.5).AND. & (abs(TMP_MEM-DM_LAST_MEM_SENT).GE. & 0.2d0*dble(LRLUS))))THEN IF ( abs( TMP_MEM-DM_LAST_MEM_SENT) > & DM_THRES_MEM ) THEN IERR = 0 SEND_MEM = TMP_MEM #endif 111 CONTINUE CALL DMUMPS_BUF_SEND_UPDATE_LOAD( & BDC_SBTR, & BDC_MEM,BDC_MD, COMM_LD, & NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & DELTA_LOAD, #else & LOAD_FLOPS( MYID ), #endif & SEND_MEM,SBTR_TMP, & DM_SUMLU, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_MEM_UPDATE",IERR CALL MUMPS_ABORT() ENDIF IF ( IERR .EQ. 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) DELTA_LOAD = ZERO DELTA_MEM = ZERO #else LAST_LOAD_SENT = LOAD_FLOPS ( MYID ) DM_LAST_MEM_SENT = TMP_MEM #endif END IF 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 ) #if ! defined(OLD_LOAD_MECHANISM) DEALLOCATE(FUTURE_NIV2) #endif 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 IERR, MSGTAG, MSGLEN, MSGSOU,COMM INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL FLAG 10 CONTINUE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) 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) 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) 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 ) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE INTEGER MSGSOU, LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INCLUDE 'mpif.h' INTEGER POSITION, IERR, WHAT, NSLAVES, i 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 ) IF ( WHAT == 0 ) THEN #if ! defined(OLD_LOAD_MECHANISM) #else #endif CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR ) #if ! defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED #else LOAD_FLOPS( MSGSOU ) = LOAD_RECEIVED #endif IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR ) #if ! defined(OLD_LOAD_MECHANISM) DM_MEM(MSGSOU) = DM_MEM(MSGSOU) + LOAD_RECEIVED #else DM_MEM(MSGSOU) = LOAD_RECEIVED #endif 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 ) 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 ) 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) WRITE(*,*)MYID,':Receiving M2A from',MSGSOU i=1 DO WHILE ((i.LE.NSLAVES).AND.(LIST_SLAVES(i).NE.MYID)) i=i+1 ENDDO IF(i.LT.(NSLAVES+1))THEN NB_LEVEL2=NB_LEVEL2+1 WRITE(*,*)MYID,':NB_LEVEL2=',NB_LEVEL2 AMI_CHOSEN=.TRUE. IF(KEEP_LOAD(73).EQ.1)THEN IF(.NOT.IS_DISPLAYED)THEN WRITE(*,*)MYID,': Begin of Incoherent state (2) at time=', & MPI_WTIME()-TIME_REF IS_DISPLAYED=.TRUE. ENDIF ENDIF ENDIF IF(KEEP_LOAD(73).EQ.1) GOTO 344 #endif #endif DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif LOAD_FLOPS(LIST_SLAVES(i)) = & LOAD_FLOPS(LIST_SLAVES(i)) + & LOAD_INCR(i) #if defined(OLD_LOAD_MECHANISM) END IF #endif END DO IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif 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))) #if defined(OLD_LOAD_MECHANISM) END IF #endif 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) 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 #if defined(OLD_LOAD_MECHANISM) #if defined(CHECK_COHERENCE) 344 CONTINUE #endif #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 ) 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 ) SBTR_MEM(MSGSOU)=SBTR_MEM(MSGSOU)+LOAD_RECEIVED #if ! defined(OLD_LOAD_MECHANISM) 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 ) MD_MEM(MSGSOU)=999999999_8 TAB_MAXS(MSGSOU)=TAB_MAXS(MSGSOU)+int(SURF,8) ENDIF #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 ) 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR ) IF( & MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE_RECEIVED)), & NPROCS).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 ) 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 ) 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 ) IF(BDC_MD)THEN #if ! defined(OLD_LOAD_MECHANISM) DM_MEM(MYID)=DM_MEM(MYID)+LOAD_RECEIVED #else DM_MEM(MYID)=LOAD_RECEIVED #endif 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 ) #if ! defined(OLD_LOAD_MECHANISM) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED #else LOAD_FLOPS( MSGSOU ) = LOAD_RECEIVED #endif 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR) DO i = 1, NSLAVES #if defined(OLD_LOAD_MECHANISM) IF ( LIST_SLAVES(i) /= MYID ) THEN #endif MD_MEM(LIST_SLAVES(i)) = & MD_MEM(LIST_SLAVES(i)) + & int(LOAD_INCR(i),8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(LIST_SLAVES(i)+1).EQ.0)THEN MD_MEM(LIST_SLAVES(i))=999999999_8 ENDIF #endif #if defined(OLD_LOAD_MECHANISM) END IF #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 ) MD_MEM(MSGSOU)=MD_MEM(MSGSOU)+int(LOAD_RECEIVED,8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(MSGSOU+1).EQ.0)THEN MD_MEM(MSGSOU)=999999999_8 ENDIF #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 ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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 #if ! defined(OLD_LOAD_MECHANISM) #if ! defined(IBC_TEST) 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) GOTO 112 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 #endif #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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif 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 #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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)), SLAVEF ) 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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) GOTO 111 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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)), NPROCS) & ) THEN RETURN ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE_LOAD(STEP_LOAD(INODE)),NPROCS))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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0), & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0), MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 112 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 CONTINUE 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) IF (WLOAD(i) < -0.5d0 ) THEN IF((MP.GT.0).AND.(LP.GE.2))THEN WRITE(MP,*)MYID,': Warning: negative load ', & WLOAD(i) ENDIF ENDIF 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)), & SLAVEF))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)), NPROCS ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL 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 #if ! defined(OLD_LOAD_MECHANISM) TO_BE_SENT=DELTA_LOAD-COST DELTA_LOAD=dble(0) #else TO_BE_SENT=LAST_LOAD_SENT-COST LAST_LOAD_SENT=LAST_LOAD_SENT-COST #endif 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 #if ! defined(OLD_LOAD_MECHANISM) DELTA_MEM=DELTA_MEM+TMP_M2 TO_BE_SENT=DELTA_MEM #else TO_BE_SENT=DM_LAST_MEM_SENT+TMP_M2 DM_LAST_MEM_SENT=DM_LAST_MEM_SENT+TMP_M2 #endif 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, & TO_BE_SENT, & MYID, KEEP_LOAD, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF 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 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)), & SLAVEF)) THEN RETURN ENDIF FATHER=MUMPS_PROCNODE(PROCNODE(STEP(FATHER_NODE)),SLAVEF) 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)), & NPROCS).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) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_UPPER_PREDICT", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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)), NPROCS ) 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 #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 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, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & 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) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error 2 in DMUMPS_LOAD_SEND_MD_INFO", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif DO i = 1, NP_TO_UPDATE MD_MEM(P_TO_UPDATE(i))=MD_MEM(P_TO_UPDATE(i))+ & int(DELTA_MD( i ),8) #if ! defined(OLD_LOAD_MECHANISM) IF(FUTURE_NIV2(P_TO_UPDATE(i)+1).EQ.0)THEN MD_MEM(P_TO_UPDATE(i))=999999999_8 ENDIF #endif ENDDO #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif DEALLOCATE(DELTA_MD,P_TO_UPDATE,IPROC2POSINDELTAMD) 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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)),NPROCS).EQ.MYID)THEN IF(INODE.EQ.KEEP_LOAD(38))THEN GOTO 666 #if ! defined(OLD_LOAD_MECHANISM) ELSE IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': i did not find ',SON CALL MUMPS_ABORT() ENDIF GOTO 666 #endif 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) #if ! defined(OLD_LOAD_MECHANISM) USE MUMPS_FUTURE_NIV2 #endif 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 defined(NOT_ATM_POOL_SPECIAL) DOUBLE PRECISION TMP #endif IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0) & .AND.(INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF #if defined(NOT_ATM_POOL_SPECIAL) IF((INODE.LT.0).OR.(INODE.GT.N_LOAD))THEN MAX_MEM=huge(MAX_MEM) DO i=0,NPROCS-1 TMP=dble(TAB_MAXS(i))-(DM_MEM(i)+LU_USAGE(i)) IF(BDC_SBTR)THEN TMP=TMP-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF MAX_MEM=min(MAX_MEM,TMP) ENDDO RETURN ENDIF #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)), & NPROCS).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)), & NPROCS).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 ! defined(OLD_LOAD_MECHANISM) 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 #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)),NPROCS).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 #if defined(NOT_ATM_POOL_SPECIAL) IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N_LOAD ) THEN NODE = POOL(LPOOL-2-J) - N_LOAD ELSE NODE = POOL(LPOOL-2-J) ENDIF #else NODE=POOL(LPOOL-2-J) #endif 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)),NPROCS).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))), & NPROCS)) 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 MUMPS_5.1.2/src/sfac_process_message.F0000664000175000017500000010272513164366262020020 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mumps_headers.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 40 ) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, 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(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,SLAVEF, & 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(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, NBPROCFILS, & N, IW, LIW, A, LA, & 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, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, COMP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF) 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)), & SLAVEF ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF)) 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)),SLAVEF) & ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'smumps_root.h' 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(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/dsol_driver.F0000664000175000017500000065612613164366266016173 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_SOLVE_DRIVER(id) USE DMUMPS_STRUC_DEF USE MUMPS_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 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,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK 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 MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL 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(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSCOMP INTEGER :: PERM_PIV_LIST(max(id%KEEP(112),1)) INTEGER :: MAP_PIVNUL_LIST(max(id%KEEP(112),1)) 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_PIV_LIST permuted array of pivots C MAP_PIVNUL_LIST: mapping of permuted list 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(:) 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_IN_RHSCOMP_F, & NB_FS_IN_RHSCOMP_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV 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.0 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 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 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_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 WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE 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) IS_INIT_OOC_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)) 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. 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_IN_RHSCOMP_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_IN_RHSCOMP_F = NB_FS_IN_RHSCOMP_TOT 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 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 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 in fact effectively C -- 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 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 WRITE(6,*) " WARNING !!! A-1 OFF and KEEP(242)= ", & KEEP(242), " is reset to zero (OFF)" C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder ELSE KEEP(242) = 0 ! no permutation ENDIF 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 id%KEEP(243)=0 id%KEEP(495)=0 IF (id%KEEP(235) .EQ. 1) THEN IF (id%KEEP(497).EQ.-1) 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 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(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 ISOL_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) WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' 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) WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' 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) WRITE(MPG,'(A)') & ' ERROR: id%NRHS not allowed to change when ICNTL(32)=1' 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) WRITE(MPG,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' 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) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE INFO(2) = 20 ! ICNTL(20) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: sparse RHS incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS 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 ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 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),MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 IF (KEEP(111).eq.-1.AND.id%NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=id%NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. id%NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=id%NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN C Ignore sparse RHS in case we compute C vectors of the null space (KEEP(111)).NE.0.) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! icntl(30) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ELSE IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' INFO(2) = 20 ! inclt(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 END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21==1) THEN IF ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) 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 (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, LSCAL ) 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((J-1)*id%LRHS + I) =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 ) & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30) 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 MUMPS_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 #if defined(RHSCOMP_BYROWS) C In case of row storage with reduced right hand side, we C do not take into account empty columns during forward. C Therefore NRHS_NONEMPTY will simply be set to id%NRHS & .AND. KEEP(221) .NE. 1 #endif & ) 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))), & id%NSLAVES ) 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))), & id%NSLAVES ) 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 C Avoid to have overflows in NFRONT * NBRHS C 32-bit integer compuitations. C Should be hopefully large-enough for a while. IF(huge(NBRHS)/id%KEEP(133).LT.NBRHS) THEN IF (PROKG) WRITE(MPG,'(A,I6,A)')'Warning: NBRHS = ',NBRHS, & ' might be too large.' NBRHS = huge(NBRHS)/id%KEEP(133)-1 ! -1 to avoid rounding pbs IF (PROKG) WRITE(MPG,'(A,I6)')'NBRHS reset to ',NBRHS END IF 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 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 (id%MYID.EQ.MASTER) THEN IF ( PROKG ) THEN WRITE( MPG, 150 ) & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30) 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).OR.(KEEP(237).NE.0).OR. & (KEEP(252).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)') & ' WARNING: Incompatible features: null space basis ', & ' 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)') & ' 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)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' 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) & WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' INFO(1) = -13 INFO(2) = id%N*NBRHS GOTO 111 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 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(111),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_SOLVE = ( 4 + KEEP(133) ) * KEEP(34) + & KEEP(133) * NBRHS * KEEP(35) & + 16 * KEEP(34) ! for request id, pointer to next + safety C -------------------------------------- C Compute an upperbound of message size C for DMUMPS_GATHER_SOLUTION C -------------------------------------- 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) 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 MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for DMUMPS_GATHER_SOLUTION id%LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) id%LBUFR_BYTES = max(id%LBUFR_BYTES,TSIZE) id%LBUFR = ( id%LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) IF ( associated (id%BUFR) ) THEN NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) ENDIF ALLOCATE (id%BUFR(id%LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) & WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' INFO(1) = -13 INFO(2) = id%LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(id%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) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C CALL MPI_BCAST(KEEP(497),1,MPI_INTEGER,MASTER, & id%COMM,IERR) 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) & WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on a slave' 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 = 3 * KEEP(28) + 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) 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 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 IF ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) 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 solution C ------------------------------------- IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN C In case of scaling we will need to scale C back the RHS. 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 40 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data%SCALING=>id%ROWSCA ENDIF IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%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 40 ENDIF NB_BYTES = NB_BYTES + int(id%KEEP(89),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF 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, LSCAL ) 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 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 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 CALL MUMPS_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 MUMPS_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 C Phase 1 : DMUMPS_PERMUTE_RHS_NS C local permutations to minimize sequential disk access C with chunck of size KEEP(84)/NSLAVES C Phase 2 : DMUMPS_SOL_APPLY_PARPERM C parallel redistribution to exploit // disk access feature IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C Phase 1 to be called on each proc 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) THEN IF ( KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ELSE 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 MUMPS_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(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 / NS ENDIF ! End 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 defined(RHSCOMP_BYROWS) C In case RHSCOMP is stored by rows, we need to ensure C that the blocks during forward and backward are the C same. For that, a simple and safe solution consists in C avoiding skipping empty columns during the forward step. IF (KEEP(221).NE.1) THEN #endif 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((PERM_RHS(JBEG_RHS) -1)*LD_RHS+I) & = 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((JBEG_RHS -1)*LD_RHS + I) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN C Reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR #if defined(RHSCOMP_BYROWS) ENDIF C In that case we will have NB_RHSSKIPPED=0 C and we have JBEG_RHS = JEND_RHS+1 IF (KEEP(221).EQ.1) THEN IF ( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) THEN DO J=JBEG_RHS, JBEG_RHS + NBRHS_EFF -1 DO I=1, id%SIZE_SCHUR id%REDRHS((J-1)*LD_REDRHS + I) = ZERO ENDDO ENDDO ENDIF ENDIF #endif 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 #if defined(RHSCOMP_BYROWS) C In case of forward-only, we do not skip empty RHS. C This would cause problems during the backward phase: since C each block of RHSCOMP has a row-major storage and inside C each block, data is congiguous, blocks must be the same C during forward and during backward. Hence NB_RHSSKIPPED C will be 0. C & .OR. KEEP(221) .EQ. 1 #endif & ) 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 defined(RHSCOMP_BYROWS) IF (NZ_THIS_BLOCK .eq. 0) THEN C Skip block, C set REDRHS, RHSCOMP will be set later IF (KEEP(221).EQ.1) THEN DO J=JBEG_RHS, JBEG_RHS+ NBRHS_EFF -1 DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDDO ELSE WRITE(*,*) "Internal error 15 is sol_driver" CALL MUMPS_ABORT() ENDIF ENDIF #else IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF #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).NE.0) ) 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 ========================================================== 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).EQ.0 .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 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_IN_RHSCOMP_TOT ) NB_FS_IN_RHSCOMP_F = NB_FS_IN_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_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT, & UNS_PERM_INV, size(UNS_PERM_INV) ! size 1 if not used & ) ENDIF ENDIF ! BUILD_POSINRHSCOMP=.TRUE. 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 #if defined(RHSCOMP_BYROWS) C Stored by rows but only inside each C block. We keep IBEG_RHSCOMP unchanged C for locality since both SCATTER_RHS and C GATHER_SOLUTION will be done block-by-block? IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 #else IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 #endif 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 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 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 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 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(PERM_RHS(I)) * & 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(PERM_RHS(I))+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+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 IF(id%MYID.EQ.MASTER) 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_IN_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 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, * - to build Ej and store it in RHSCOMP K=1 ! Column index in RHSCOMP id%RHSCOMP(1:NBRHS_EFF*LD_RHSCOMP) = 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_IN_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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP((IPOSRHSCOMP-1)*NBRHS_EFF+K) = & RHS_SPARSE_COPY(IPOS) #else id%RHSCOMP((K-1)*LD_RHSCOMP+IPOSRHSCOMP) = & RHS_SPARSE_COPY(IPOS) #endif 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 #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error 17 is sol driver" CALL MUMPS_ABORT() #else DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, LD_RHSCOMP id%RHSCOMP((K-1)*LD_RHSCOMP + I) = ZERO ENDDO ENDDO #endif ENDIF #if defined(RHSCOMP_BYROWS) IF (I_AM_SLAVE) THEN DO I=1, NBENT_RHSCOMP DO K = 1, NBCOL_INBLOC C NBCOL_INBLOC is equal to NBRHS_EFF in this case id%RHSCOMP(IBEG_RHSCOMP+ & int(I-1,8)*int(NBRHS_EFF,8)+int(K-1,8))=ZERO ENDDO ENDDO ENDIF C Test below must be done also on non-working host !! IF (NZ_THIS_BLOCK .EQ. 0 .AND. KEEP(221).EQ.1) THEN C Skip the rest, go to next block. GOTO 1000 ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = IBEG_RHSCOMP + int(K-1,8) #else 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 #endif 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_IN_RHSCOMP_TOT IF ( (IPOSRHSCOMP.LE.NB_FS_IN_RHSCOMP_TOT) & .AND.(IPOSRHSCOMP.GT.0) ) THEN C ! I is fully summed var mapped on my proc #if defined(RHSCOMP_BYROWS) id%RHSCOMP(KDEC+(IPOSRHSCOMP-1)*NBRHS_EFF)= & id%RHSCOMP(KDEC+(IPOSRHSCOMP-1)*NBRHS_EFF) + & RHS_SPARSE_COPY(IZ) #else id%RHSCOMP(KDEC+IPOSRHSCOMP)= & id%RHSCOMP(KDEC+IPOSRHSCOMP) + & RHS_SPARSE_COPY(IZ) #endif 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 IF (INTERLEAVE_PAR .AND.(id%NSLAVES .GT. 1) ) THEN IRHS_SPARSE_COPY(II) = PERM_PIV_LIST(I) ELSE IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) ENDIF 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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP(1:NBRHS_EFF*LD_RHSCOMP)=ZERO #else 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 #endif 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 IF ((KEEP(235).NE.0) .AND. INTERLEAVE_PAR) THEN C When the PIVNUL_LIST has been permuted (in PERM_PIV_LIST) C then to exploit sparsity RHSCOMP need be initialized with c some care; taking into acount the processor localisation C of the indices of the null pivots. DO I=IBEG_GLOB_DEF,IEND_GLOB_DEF C Local processor is concerned by I-th column of C global right-hand side. IF (id%MYID_NODES .EQ. MAP_PIVNUL_LIST(I) ) THEN JJ= id%POSINRHSCOMP_ROW(PERM_PIV_LIST(I)) IF (JJ.GT.LD_RHSCOMP) THEN WRITE(6,*) ' Internal Error 10 JJ, LD_RHSCOMP=', & JJ, LD_RHSCOMP ENDIF IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN C unsymmetric : always set to fixation used during facto C because during factorization we aimed at preserving the C sign of the diagonal element, sign here may be different C from sign of corresponding diagonal element (not critical) #if defined(RHSCOMP_BYROWS) id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)* int(NBRHS_EFF,8)) = #else id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8)) = #endif & abs(id%DKEEP(2)) ELSE #if defined(RHSCOMP_BYROWS) id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8) *int(NBRHS_EFF,8)) = ONE #else id%RHSCOMP(IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8)) = ONE #endif ENDIF ENDIF ENDIF ENDDO ELSE 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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)*int(NBRHS_EFF,8) ) = #else id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8) ) = #endif & id%DKEEP(2) ELSE ! Symmetric: always set to one #if defined(RHSCOMP_BYROWS) id%RHSCOMP( IBEG_RHSCOMP+int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)*int(NBRHS_EFF,8) )= #else id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8)+ & int(JJ-1,8) )= #endif & ONE ENDIF ENDIF ENDDO ENDIF ! exploit sparsity 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 IF(id%MYID.EQ.MASTER) THEN TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 ENDIF 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, & id%BUFR(1), id%LBUFR, id%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, & id%BUFR(1), id%LBUFR, id%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) C size 1 if not used & , UNS_PERM_INV, NB_FS_IN_RHSCOMP_F, NB_FS_IN_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 TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) 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 #if defined(RHSCOMP_BYROWS) LCWORK = NBRHS_EFF #else LCWORK = max(max(KEEP(247),KEEP(246)),1) #endif ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) 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 ) IF(id%MYID.EQ.MASTER) 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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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_IN_RHSCOMP_TOT & ) ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 ENDIF 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 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 COLSIZE = id%IRHS_PTR(PERM_RHS(J)+1) - & id%IRHS_PTR(PERM_RHS(J)) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 c IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PERM_RHS(J)), & id%IRHS_PTR(PERM_RHS(J)+1)-1 I = id%IRHS_SPARSE (IZ) DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN WRITE(6,*) " Internal Error 13 in solution ", & " driver, gather " CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ELSE ! Not (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 COLSIZE = id%IRHS_PTR(J+1) - id%IRHS_PTR(J) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 c IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(J), id%IRHS_PTR(J+1) - 1 I = id%IRHS_SPARSE (IZ) DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN WRITE(6,*) " Internal Error 14 in solution", & " driver, gather " CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR 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, 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 ) 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 ) 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 #if defined(RHSCOMP_BYROWS) 1000 CONTINUE #endif 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((PERM_RHS(JBEG_NEW) -1)*LD_RHS+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((JBEG_NEW -1)*LD_RHS + 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((PERM_RHS(JBEG_NEW) -1)*id%LSOL_LOC+I) & = 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((JBEG_NEW -1)*LD_REDRHS + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN #if defined(RHSCOMP_BYROWS) DO I=1,NBENT_RHSCOMP JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) id%RHSCOMP(JBEG_NEW + (I-1)*NBRHS_EFF) = ZERO JBEG_NEW = JBEG_NEW +1 ENDDO ENDDO #else JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSCOMP id%RHSCOMP((JBEG_NEW -1)*LD_RHSCOMP + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO #endif 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 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 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 IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Global statistics" WRITE( MPG, 434 ) id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) WRITE( MPG, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(116) ! non-zero if gather WRITE( MPG, 431 ) id%DKEEP(122) ! Distributed solution 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(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(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 (associated(id%BUFR)) THEN NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 DEALLOCATE(id%BUFR) NULLIFY(id%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%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%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 RHS (dist.sol)=',F15.6) 150 FORMAT(/' 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) 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_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_IN_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, id%BUFR(1), id%LBUFR, & id%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, C Case of special root node & 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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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.1.2/src/dmumps_iXamax.F0000664000175000017500000000105613164366263016452 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C INTEGER FUNCTION DMUMPS_IXAMAX(N,X,INCX) DOUBLE PRECISION X(*) INTEGER INCX,N INTEGER idamax DMUMPS_IXAMAX = idamax(N,X,INCX) RETURN END FUNCTION DMUMPS_IXAMAX MUMPS_5.1.2/src/dlr_core.F0000664000175000017500000007652313164366266015445 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE DMUMPS_LR_CORE USE MUMPS_LR_COMMON USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,KSVD,M,N,ISLR) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,KSVD,M,N LOGICAL,INTENT(IN) :: ISLR C This routine simply initializes a LR block but does NOT allocate it LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%KSVD = KSVD LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) IF (ISLR) THEN LRB_OUT%LRFORM = 1 ELSE LRB_OUT%LRFORM = 0 ENDIF END SUBROUTINE INIT_LRB SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS, K486, K489, & K490, K491, K492, N, LRGROUPS, LRSTATUS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, K486, K489, K490, & K491, K492 INTEGER,INTENT(IN) :: N, LRGROUPS(N) INTEGER,INTENT(OUT):: LRSTATUS C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB COMPRESS_PANEL = .FALSE. IF ((K486.GT.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.EQ.1) COMPRESS_PANEL =.FALSE. IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF COMPRESS_CB = .FALSE. IF ((K492.GT.0).AND.(K489.EQ.1).AND.(NFRONT-NASS.GT.K491)) THEN COMPRESS_CB = .TRUE. ENDIF 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 END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,KSVD,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,KSVD,M,N INTEGER,INTENT(OUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok DOUBLE PRECISION :: ZERO PARAMETER (ZERO = 0.0D0) 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) write(*,*) 'Allocation problem in BLR routine ALLOC_LRB:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF ENDIF ELSE allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N write(*,*) 'Allocation problem in BLR routine ALLOC_LRB:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF nullify(LRB_OUT%R) ENDIF LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%KSVD = KSVD LRB_OUT%ISLR = ISLR IF (ISLR) THEN LRB_OUT%LRFORM = 1 ELSE LRB_OUT%LRFORM = 0 ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF KEEP8(70) = KEEP8(70) - int(MEM,8) KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - int(MEM,8) KEEP8(69) = min(KEEP8(71), KEEP8(69)) END SUBROUTINE ALLOC_LRB 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 LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2 ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1)) 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)) DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE DMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, POSELTD, & 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_LRGEMM3) 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) :: POSELTD, POSELTT INTEGER, INTENT(IN) :: MAXI_CLUSTER DOUBLE PRECISION, intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS DOUBLE PRECISION :: PIV1, PIV2, OFFDIAG IF (LRB%LRFORM.EQ.1) THEN NROWS = LRB%K ELSE ! Full Rank Block NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot 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: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_LRGEMM3(TRANSB1, TRANSB2, ALPHA, & LRB1, LRB2, BETA, A, LA, POSELTT, NFRONT, SYM, NIV, & IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, RANK, BUILDQ, & POSELTD, LD_DIAG, IW2, BLOCK, MAXI_CLUSTER) TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, NIV INTEGER,INTENT(OUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8), INTENT(IN), OPTIONAL :: POSELTD INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER CHARACTER(len=1),INTENT(IN) :: TRANSB1, TRANSB2 INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION :: ALPHA,BETA DOUBLE PRECISION, intent(inout), OPTIONAL :: BLOCK(:) DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: XY_YZ DOUBLE PRECISION, ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSX, TRANSY, TRANSZ INTEGER :: M_X, K_XY, K_YZ, N_Z, LDX, LDY, LDY1, LDY2, LDZ, K_Y INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK LOGICAL :: BUILDQ DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) DOUBLE PRECISION, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: T1, T2, CR INTEGER :: allocok, MREQ DOUBLE PRECISION :: LOC_UPDT_TIME_OUT DOUBLE PRECISION, EXTERNAL ::dnrm2 DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (LRB2%M.EQ.0) THEN write(*,*) "Internal error in DMUMPS_LRGEMM3, LRB2%M=0" CALL MUMPS_ABORT() ENDIF IF ((SYM.NE.0).AND.((TRANSB1.NE.'N').OR.(TRANSB2.NE.'T'))) THEN WRITE(*,*) "SYM > 0 and (", TRANSB1, ",", TRANSB2, & ") parameters found. Symmetric LRGEMM is only ", & "compatible with (N,T) parameters" CALL MUMPS_ABORT() ENDIF RANK = 0 BUILDQ = .FALSE. IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==1)) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) GOTO 700 allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 860 ENDIF IF (TRANSB1 == 'N') THEN X => LRB1%Q LDX = LRB1%M M_X = LRB1%M 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K ELSE !TRANSB1 == 'T' M_X = LRB1%N X => LRB1%R LDX = LRB1%K K_Y = LRB1%M Y1 => LRB1%Q LDY1 = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN Z => LRB2%R LDZ = LRB2%K N_Z = LRB2%N Y2 => LRB2%Q LDY2 = LRB2%M ELSE !TRANSB2 == 'T' N_Z = LRB2%M Z => LRB2%Q LDZ = LRB2%M Y2 => LRB2%R LDY2 = LRB2%K ENDIF TRANSZ = TRANSB2 CALL dgemm(TRANSB1 , TRANSB2 , LRB1%K , LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) BUILDQ = .FALSE. IF (COMPRESS_MID_PRODUCT.GE.1) THEN LWORK = MAX(LRB2%K**2, M_X**2) 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 860 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(1), TAU_RRQR(1), WORK_RRQR(1), & LRB2%K, RWORK_RRQR(1), TOLEPS, RANK, MAXRANK, INFO) IF ((RANK.GT.MAXRANK).OR.(RANK.EQ.0)) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN ! Successfully compressed middle block allocate(XQ(M_X,RANK), R_Y(RANK,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = M_X*RANK + RANK*LRB2%K GOTO 860 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 CALL dorgqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL dgemm(TRANSB1, 'N', M_X, RANK, LRB1%K, ONE, & X(1,1), LDX, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), M_X) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ LDX = M_X K_XY = RANK TRANSX = 'N' deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSX = TRANSB1 TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE ! LRB1%K < LRB2%K SIDE = 'R' ENDIF ENDIF ENDIF IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN IF (LRB1%K.EQ.0) GOTO 700 SIDE = 'R' K_XY = LRB1%K TRANSX = TRANSB1 TRANSY = TRANSB1 Z => LRB2%Q LDZ = LRB2%M TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN X => LRB1%Q LDX = LRB1%M M_X = LRB1%M 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF ELSE ! TRANSB1 == 'T' X => LRB1%R LDX = LRB1%K M_X = LRB1%N Y => LRB1%Q LDY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN K_YZ = LRB2%M N_Z = LRB2%N ELSE ! TRANSB2 == 'T' K_YZ = LRB2%N N_Z = LRB2%M ENDIF ENDIF IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN IF (LRB2%K.EQ.0) GOTO 700 SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q LDX = LRB1%M TRANSX = TRANSB1 TRANSY = TRANSB2 TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN M_X = LRB1%M K_XY = LRB1%N ELSE ! TRANSB1 == 'T' M_X = LRB1%N K_XY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN Y => LRB2%Q LDY = LRB2%M Z => LRB2%R LDZ = LRB2%K N_Z = LRB2%N ELSE ! TRANSB2 == 'T' IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE ! Symmetric case: column scaling of R2 is done allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q LDZ = LRB2%M N_Z = LRB2%M ENDIF ENDIF IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) 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 860 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, POSELTD, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' LDX = LRB1%M TRANSX = TRANSB1 Z => LRB2%Q LDZ = LRB2%M TRANSZ = TRANSB2 IF (TRANSB1 == 'N') THEN M_X = LRB1%M K_XY = LRB1%N ELSE ! TRANSB1 == 'T' M_X = LRB1%N K_XY = LRB1%M ENDIF IF (TRANSB2 == 'N') THEN N_Z = LRB2%N ELSE ! TRANSB2 == 'T' N_Z = LRB2%M ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z allocate(XY_YZ(M_X,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = M_X*K_YZ GOTO 860 ENDIF CALL dgemm(TRANSX , TRANSY , M_X , K_YZ, K_XY, ONE, & X(1,1), LDX, Y(1,1), LDY, ZERO, XY_YZ(1,1), M_X) CALL SYSTEM_CLOCK(T1) CALL dgemm('N', TRANSZ, M_X, N_Z, K_YZ, ALPHA, & XY_YZ(1,1), M_X, Z(1,1), LDZ, BETA, A(POSELTT), & NFRONT) CALL SYSTEM_CLOCK(T2,CR) LOC_UPDT_TIME_OUT = dble(T2-T1)/dble(CR) CALL UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) deallocate(XY_YZ) ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ allocate(XY_YZ(K_XY,N_Z),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*N_Z GOTO 860 ENDIF CALL dgemm(TRANSY , TRANSZ , K_XY , N_Z, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LDZ, ZERO, XY_YZ(1,1), K_XY) CALL SYSTEM_CLOCK(T1) CALL dgemm(TRANSX, 'N', M_X, N_Z, K_XY, ALPHA, & X(1,1), LDX, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) CALL SYSTEM_CLOCK(T2,CR) LOC_UPDT_TIME_OUT = dble(T2-T1)/dble(CR) CALL UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) deallocate(XY_YZ) ELSE ! SIDE == 'N' : NONE; A = X*Z CALL dgemm(TRANSX, TRANSZ, M_X, N_Z, K_XY, ALPHA, & X(1,1), LDX, Z(1,1), LDZ, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 870 860 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine DMUMPS_LRGEMM3: ', & 'not enough memory? memory requested = ' , MREQ IFLAG = - 13 IERROR = MREQ RETURN 870 CONTINUE C Alloc ok!! IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE ! 1 AND 1 IF ((TRANSB1=='N').AND.(SYM .NE. 0)) deallocate(Y1) IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 700 CONTINUE END SUBROUTINE DMUMPS_LRGEMM3 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 END MODULE DMUMPS_LR_CORE SUBROUTINE DMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, 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 The authors of the LAPACK library are: C - Univ. of Tennessee C - Univ. of California Berkeley C - Univ. of Colorado Denver C - NAG Ltd. IMPLICIT NONE INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK DOUBLE PRECISION :: TOLEPS INTEGER :: JPVT(*) DOUBLE PRECISION :: RWORK(*) DOUBLE PRECISION :: A(LDA,*), TAU(*) DOUBLE PRECISION :: WORK(LDW,*) 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 CALL XERBLA( 'CGEQP3', -INFO ) RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RETURN END IF NB = ILAENV( INB, 'CGEQRF', ' ', M, N, -1, -1 ) 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 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 ) C IF(VN1(PVT).LT.TOLEPS) THEN IF(RWORK(PVT).LT.TOLEPS) 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 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 END DO RANK = RK END SUBROUTINE DMUMPS_TRUNCATED_RRQR MUMPS_5.1.2/src/zfac_mem_alloc_cb.F0000664000175000017500000001606013164366265017240 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, IFLAG, IERROR ) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, 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 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 LOGICAL DONE 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)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF IF (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 DONE =.FALSE. IF ((IPTRLU.LT.LREQCB_WISHED).OR.(LRLU.LT.LREQCB_WISHED)) THEN IF (LRLUS.LT.LREQCB_EFF) THEN GOTO 620 ELSE 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... ZMUMPS_ALLOC_CB', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF DONE = .TRUE. ENDIF ENDIF IF (IWPOSCB-IWPOS+1 .LT. LREQ) THEN IF (DONE) GOTO 600 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... ZMUMPS_ALLOC_CB', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF IF (IWPOSCB-IWPOS+1 .LT. LREQ) GOTO 600 ENDIF 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+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXP+1:IWPOSCB+1+KEEP(IXSZ))=-99999 #if ! defined(NO_XXNBPR) IW(IWPOSCB+1+XXNBPR)=0 #endif ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LREQCB_EFF KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQCB_EFF KEEP8(69) = min(KEEP8(71), KEEP8(69)) #if ! defined(OLD_LOAD_MECHANISM) CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #else #if defined (CHECK_COHERENCE) CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #else CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) #endif #endif RETURN 600 IFLAG = -8 IERROR = LREQ RETURN 620 IFLAG = -9 CALL MUMPS_SET_IERROR(LREQCB_EFF - LRLUS, IERROR) RETURN END SUBROUTINE ZMUMPS_ALLOC_CB MUMPS_5.1.2/src/zfac_process_contrib_type2.F0000664000175000017500000003410213164366265021162 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ), FILS( N ) 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 'mumps_headers.h' 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 #if ! defined(NO_XXNBPR) INTEGER :: INBPROCFILS_SON #endif 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 ) MASTER = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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) 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 ) CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN 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 ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ZMUMPS_PROCESS_CONTRIB_TYPE2' WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR( LREQA - LRLUS, IERROR ) CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END IF END IF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQA KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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 NBPROCFILS(STEP(INODE))=NBPROCFILS(STEP(INODE))-NBROW #if ! defined(NO_XXNBPR) IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW #endif 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 ) 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 ) 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 CALL ZMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ELSE 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 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 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - DECR NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB #if ! defined(NO_XXNBPR) 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 #endif #if ! defined(NO_XXNBPR) IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN #endif 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_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF #if ! defined(NO_XXNBPR) IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN #else IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN #endif CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + 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.1.2/src/dfac_process_root2slave.F0000664000175000017500000002613113164366263020452 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE DMUMPS_LOAD USE DMUMPS_OOC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ), 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) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) 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 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)), & SLAVEF ) ) 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 (KEEP(60) .NE. 0) THEN IF (root%yes) THEN IF ( NEW_LOCAL_M .NE. root%SCHUR_MLOC .OR. & NEW_LOCAL_N .NE. root%SCHUR_NLOC ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_PROCESS_ROOT2SLAVE" CALL MUMPS_ABORT() ENDIF ENDIF PTLUST(STEP(IROOT)) = -4444 PTRFAC(STEP(IROOT)) = -4445_8 PTRIST(STEP(IROOT)) = 0 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 ) 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)) 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 ENDIF GOTO 100 ENDIF 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) 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) GOTO 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 ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB2 compress root2slave: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 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(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQA KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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)) 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 )) .LE. 0 ) THEN PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 IF (LREQA.GT.0_8) A(PTRAST(STEP(IROOT)): & PTRAST(STEP(IROOT))+LREQA-1_8) = ZERO 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(.FALSE., MYID, N, IPOS_SON, & PAMASTER(STEP(IROOT)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 END IF END IF IF (NEW_LOCAL_M.GT.OLD_LOCAL_M) 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 100 CONTINUE NBPROCFILS(STEP(IROOT))=NBPROCFILS(STEP(IROOT)) + TOT_CONT_TO_RECV #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN #endif 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(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.1.2/src/mumps_io.h0000664000175000017500000001427013164366240015525 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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_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.1.2/src/cfac_front_type2_aux.F0000664000175000017500000006540013164366265017747 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NNEG, & 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) 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, NNEG INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR INTEGER, intent(inout) :: Inextpiv 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 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 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(201).EQ.1 .AND. KEEP(50).NE.1) 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 IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF ELSE IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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 APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG (IPIV) = abs(A(POSPV1)) 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 (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) 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 = max(abs(A(J1)),AMAX) 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)),RMAX_NOSLAVE) J1 = J1 + LDAFS8 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 KEEP(109) = KEEP(109)+1 PIVNUL_LIST(KEEP(109)) = -1 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 + LDAFS8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO DO J=1,NASS - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDAFS8 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 IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) 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 J1 = POSPV1 + LDAFS8 DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(J1)),RMAX_NOSLAVE) ENDIF J1 = J1 + LDAFS8 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 IF (KEEP(258).NE.0) THEN CALL CMUMPS_UPDATEDETER(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(105) = KEEP(105)+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 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(201).EQ.1.AND.KEEP(50).NE.1) 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) 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 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(NASS - NPIV_NEW,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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, SEND_LR, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_LR_TYPE IMPLICIT NONE INCLUDE 'cmumps_root.h' 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(40) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), & 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)), & NBPROCFILS(KEEP(28)), 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) :: SEND_LR 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 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 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, & SEND_LR, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/dfac_asm_master_ELT_m.F0000664000175000017500000016332313164366264017775 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,NBPROCFILS, 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 MUMPS_BUILD_SORT_INDEX_ELT_M USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N,LIW,NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS 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))) LOGICAL SON_LEVEL2 DOUBLE PRECISION, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NBPROCFILS(KEEP(28)), NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INTEGER ETATASS LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE 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 INTEGER(8) NFRONT8, LAELL8 INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC INTEGER(8) LSTK8, SIZFR8 INTEGER SIZFI, NCB 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 NCOLS, NROWS, LDA_SON INTEGER NELIM, & IORG, IBROT 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, POINTER :: SON_IWPOS INTEGER, POINTER, DIMENSION(:) :: SON_IW DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC 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 COMPRESSCB =.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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 LREQ_OOC = 0 IF (KEEP(201).EQ.1) 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) 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, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, 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)), & SLAVEF))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) 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 NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress DMUMPS_FAC_ASM_NIV1_ELT' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) #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=3000 !$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 NUMROWS = NFRONT8 TOPDIAG = max(KEEP(7), KEEP(8), KEEP(57), KEEP(58))-1 !$ 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 NASS = NASS1 PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = SON_IW(ISTCHK + 3+KEEP(IXSZ)) 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 COMPRESSCB = & ( SON_IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( SON_IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF 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) THEN K2 = K1 + LSTK - 1 IF (COMPRESSCB) 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 SIZFR8 = int(NELIM,8) * int(NELIM,8) END IF K2 = K1 + NELIM - 1 ENDIF OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) 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) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR8 ELSE LCB = int(LDA_SON,8) * int(K2-K1+1,8) ENDIF IF (LCB .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB & ) 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(SSARBR, MYID, N, ISTCHK, & IACHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 END DO 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 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 280 CONTINUE INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_ASM_NIV1_ELT' ENDIF GOTO 500 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 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, & NBPROCFILS, 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(40) 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 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))) DOUBLE PRECISION A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW 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 LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)), 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 INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 ETATASS 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(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 :: 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)) COMPRESSCB=.FALSE. ETATASS = 0 IN = INODE NBPROCFILS(STEP(IN)) = 0 NSTEPS = NSTEPS + 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)), & SLAVEF) .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) MAXFRW = max0(MAXFRW, NFRONT) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 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)), & SLAVEF) 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)), & SLAVEF) 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)), & SLAVEF) 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) 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) 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) 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) GOTO 275 CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, 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) 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) #if defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) IF ( KEEP(73) .EQ. 0 ) THEN #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 defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) ENDIF #endif #endif 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 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress DMUMPS_FAC_ASM_NIV2_ELT' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), IW(IOLDPS+XXNBPR)) #endif 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 = max(int(KEEP(361)/2,8), !$ & (LAELL8+NOMP-1) / NOMP ) !$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 ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 !$ 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 + KEEP(IXSZ) + 3) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) 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) + 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) + A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (NSLSON.EQ.0) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF IF (LCB .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & COMPRESSCB & ) 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, & 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), & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 280 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) 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.1.2/src/cmumps_driver.F0000664000175000017500000025523613164366266016533 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 -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, 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). These 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. * * 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. 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. * Other values for the parameter JOB can invoke combinations of these * three basic operations. 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_8) THEN id%KEEP8(29) = id%NNZ_loc ELSE id%KEEP8(29) = int(id%NZ_loc, 8) ENDIF ENDIF C C IF (JOB.EQ.-2.OR.JOB.EQ.1.OR.JOB.EQ.2.OR.JOB.EQ.3.OR. & JOB.EQ.4.OR.JOB.EQ.5.OR.JOB.EQ.6 & ) THEN C Correct value of JOB C ICNTL should have been initialized and can be used LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%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 (id%KEEP(500).EQ.1) THEN FROM_C_INTERFACE_STRING=" from C interface" ELSE FROM_C_INTERFACE_STRING=" " ENDIF IF (PROKG) THEN C Print basic information on MUMPS call IF (JOB .EQ. -2 & ) THEN C N, NELT, NNZ not meaningful WRITE(MPG,'(/A,A,A,A,I4,I12)') & 'Entering CMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB =', JOB ELSE IF (id%ICNTL(5) .NE. 1) THEN C Assembled format IF (id%ICNTL(18) .EQ. 0 & ) THEN WRITE(MPG,'(/A,A,A,A,I4,I12,I15)') & 'Entering CMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB, N, NNZ =', JOB,id%N,id%KEEP8(28) ELSE WRITE(MPG,'(/A,A,A,A,I4,I12)') & 'Entering CMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB, N =', JOB,id%N ENDIF ELSE C Elemental format WRITE(MPG,'(/A,A,A,A,I4,I12,I15)') & 'Entering CMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' driver with JOB, N, NELT =', JOB,id%N,id%NELT ENDIF C MPI and OpenMP information !$ IF (.TRUE.) THEN !$ WRITE(MPG, '(A,I6,A,I6)') ' executing #MPI = ', !$ & id%NPROCS, ' and #OMP = ', NOMP !$ IF ( NOMPMIN .NE. NOMPMAX ) THEN !$ WRITE(MPG, '(A,I4,A,I4,A)') !$ & ' WARNING detected: different number of threads (max ', !$ & NOMPMAX, ', min ', NOMPMIN, ')' !$ END IF !$ ELSE WRITE(MPG, '(A,I6,A)') ' executing #MPI = ', & id%NPROCS, ', without OMP' !$ ENDIF IF (JOB.GE.1 .AND. JOB.LE.6) THEN WRITE(MPG, '(A)') ENDIF ENDIF END IF C C---------------------------------------------------------------- C C JOB = -1 : START INITIALIZATION PHASE C (NEW INSTANCE) C C JOB = -2 : TERMINATE AN INSTANCE C---------------------------------------------------------------- C IF ( JOB .EQ. -1 ) THEN C C ------------------------------------------ C Check that we have called (JOB=-2), ie C that the previous JOB is not 1 2 or 3, C before calling the initialization routine. C -------------------------------------------- id%INFO(1)=0 id%INFO(2)=0 OLDJOB = id%KEEP( 40 ) + 456789 IF ( OLDJOB .EQ. 1 .OR. & OLDJOB .EQ. 2 .OR. & OLDJOB .EQ. 3 ) THEN IF ( id%N > 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---------------------------------------------------------------- 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----------------------------------------------------------------------- C TIMINGS IF (id%MYID .eq. MASTER) THEN id%DKEEP(70)=0.0E0 CALL MUMPS_SECDEB(TIMETOTAL) END IF OLDJOB = id%KEEP( 40 ) + 456789 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 IS1 :allocated on the master now, will be allocated on C the slaves later 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 IF (associated(id%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) ENDIF C ------------------------------------------- C Allocate array IS1 for analysis of size: C - assembled entry: 10 * N or 11 * N C depending on max-trans C - element entry: 7 * N + 3 * NELT + 3 C max-trans not allowed C ------------------------------------------- IF ( id%ICNTL(5) .NE. 1 ) THEN ! assembled matrix IF ( id%KEEP(50) .NE. 1 & .AND. ( & (id%ICNTL(6) .NE. 0 .AND. id%ICNTL(7) .NE.1) & .OR. & id%ICNTL(12) .NE. 1) ) THEN id%MAXIS1 = 7 * id%N ELSE id%MAXIS1 = 6 * id%N END IF ELSE id%MAXIS1 = 6 * id%N ENDIF ALLOCATE( id%IS1(id%MAXIS1), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%MAXIS1 IF ( LPOK ) WRITE(LP,'(A)') & ' Problem in allocating work array for analysis' GO TO 100 END IF C C ---------------------- C Allocate PROCNODE(1:N) C ---------------------- IF ( associated( id%PROCNODE ) ) & DEALLOCATE( id%PROCNODE ) ALLOCATE( id%PROCNODE(id%N), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%N IF ( LPOK ) WRITE(LP,'(A)') & 'Problem in allocating work array PROCNODE' GOTO 100 END IF id%PROCNODE(1:id%N) = 0 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. 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 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 ------------------------------------------- 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 CALL CMUMPS_ANA_DRIVER( id ) C Save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ELSE id%INFOG(33)=id%ICNTL(8) ENDIF 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 (id%MYID .eq. MASTER.AND.id%KEEP(492).EQ.0) THEN C No front to be selected for LR id%KEEP(486) = 0 IF (PROKG) & write(MPG,'(A)') " Low rank reset off since no front selected " 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), & id%SIZE_SCHUR*id%SIZE_SCHUR) 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( id%KEEP(52) .EQ. -2 .AND. id%ICNTL(8) .NE. -2 .AND. & id%ICNTL(8).NE. 77 ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** scaling already computed during analysis' WRITE(MPG,'(A)') & ' ** keeping the scaling from the analysis' ENDIF ENDIF IF (id%KEEP(52) .NE. -2) THEN 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 IF ( id%KEEP( 19 ) .ne. 0 .and. id%KEEP( 52 ).ne. 0 ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') ' ** (incompatibility with null space)' END IF id%KEEP(52) = 0 END IF 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 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) id%INFO(1)=-13 ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 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) id%INFO(1)=-13 IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 IF ( id%INFO(1) .eq. -13 ) THEN 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) 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), & id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) 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)) 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 (associated(id%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) ENDIF IF (associated(id%PROCNODE)) THEN DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) ENDIF #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(TIMEG) ENDIF 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 = 40 INTEGER :: INFO(40) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(40) 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 .and. INFO(2) .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 SUBROUTINE CMUMPS_PRINT_ICNTL(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 INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL 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) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 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,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) 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) WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) CASE(5); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(6); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 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) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 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 =',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 ( 0= off, else=on) =',I10/ & 'ICNTL(20) Dense (0) or sparse (1) 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) Dense (0) or sparse (1) 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 & (size(idRHS)<(idNRHS*idLRHS-idLRHS+idN)) & 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.1.2/src/stools.F0000664000175000017500000007630313164366262015167 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 LOGICAL MOVEPTRAST LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR 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 IF (LDLT.EQ.0) THEN SIZECB = int(LCONT,8) * int(LCONT,8) ELSE SIZECB = int(NROW,8) * int(LCONT,8) ENDIF END IF CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZECB ) IF ((SIZECB.EQ.0_8).AND.(KEEP(201).EQ.0)) THEN GOTO 500 ENDIF IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL SMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) 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 ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF(KEEP(201).EQ.0)THEN PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB ELSE PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) - & SIZECB - SIZELU ENDIF MOVEPTRAST = .TRUE. IF(KEEP(201).EQ.0)THEN PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB ELSE PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB & - SIZELU ENDIF ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF(KEEP(201).EQ.0)THEN PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3))-SIZECB ELSE PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZECB-SIZELU ENDIF ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF(KEEP(201).EQ.0)THEN PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB ELSE PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB & - SIZELU ENDIF END IF IPS = IPS + IPSIZE END DO IF ((SIZECB .NE. 0_8).OR.(KEEP(201).NE.0)) THEN IF (KEEP(201).NE.0) THEN DO I=IAPOS, POSFAC - SIZECB - SIZELU - 1_8 A( I ) = A( I + SIZECB + SIZELU) END DO ELSE DO I=IAPOS + SIZELU, POSFAC - SIZECB - 1_8 A( I ) = A( I + SIZECB ) END DO ENDIF END IF ENDIF IF (KEEP(201).NE.0) THEN POSFAC = POSFAC - (SIZECB+SIZELU) LRLU = LRLU + (SIZECB+SIZELU) LRLUS = LRLUS + (SIZECB+SIZELU) - SIZE_INPLACE KEEP8(70) = KEEP8(70) + (SIZECB+SIZELU) - SIZE_INPLACE KEEP8(71) = KEEP8(71) + (SIZECB+SIZELU) - SIZE_INPLACE ELSE POSFAC = POSFAC - SIZECB LRLU = LRLU + SIZECB LRLUS = LRLUS + SIZECB - SIZE_INPLACE KEEP8(70) = KEEP8(70) + SIZECB - SIZE_INPLACE KEEP8(71) = KEEP8(71) + SIZECB - SIZE_INPLACE IF (LRCOMPRESS_PANEL) THEN KEEP8(71) = KEEP8(71) + SIZELU ENDIF ENDIF 500 CONTINUE CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE,KEEP,KEEP8,LRLUS) 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, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) USE SMUMPS_OOC USE SMUMPS_LOAD 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(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) :: LAFAC, 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) 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 )) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS_CB+XXR)) 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_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRAST(STEP(ISON))), LAFAC, 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) 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 ) 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(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), 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+XXI)=LREQI CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXS)=-9999 IW(POSI+XXS+1:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXLR) = LRSTATUS 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 POSALOC = POSA DO I = 1, NROW_L OLDPOS = PTRAST( STEP(ISON)) + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = 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 KEEP8(10) = KEEP8(10) + int(NCOL_L,8) * int(NROW_L,8) 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 KEEP8(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + LREQA 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 & ) 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 ISTCHK = PTRIST(STEP(ISON)) CALL SMUMPS_FREE_BLOCK_CB(.FALSE.,MYID, N, ISTCHK, & PTRAST(STEP(ISON)), & 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_MAX_MEM( KEEP,KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, PERLU_ON, & MEMORY_BYTES ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON INTEGER, INTENT(IN) :: OOC_STRAT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID, N, NELT, NSLAVES, LNA INTEGER(8) :: NA_ELT8, NNZ8 INTEGER(8), INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT) :: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL, MAXS_MIN 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 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 ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MAXS_MIN = KEEP8(14) ELSE MAXS_MIN = KEEP8(12) ENDIF IF ( .NOT. EFF ) THEN IF ( KEEP8(24).EQ.0_8 ) THEN NB_REAL = NB_REAL + MAXS_MIN + & int(PERLU,8)*(MAXS_MIN / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + KEEP8(67) 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 SMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) SMUMPS_LBUFR_BYTES8 = max( SMUMPS_LBUFR_BYTES8, & 100000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF 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(43))-100,8)) NB_BYTES = NB_BYTES + SMUMPS_LBUFR_BYTES8 SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 43 ) * KEEP( 35 )), 8 ) 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 SMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(SMUMPS_LBUF_INT,8) IF ( EFF ) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int(KEEP(225),8) ELSE NB_INT = NB_INT + int(KEEP(15),8) ENDIF ELSE 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(486).NE.0) THEN NB_INT = NB_INT + N8 NB_REAL = NB_REAL + & int(KEEP(127),8)*int(KEEP(488),8) ENDIF END IF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = int( MEMORY_BYTES / 1000000_8 ) + 1 RETURN END SUBROUTINE SMUMPS_MAX_MEM 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_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,COMPRESSCB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL COMPRESSCB REAL A(ASIZE) REAL M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW REAL ZERO,TMP PARAMETER (ZERO=0.0E0) M_ARRAY(1:NMAX) = ZERO APOS = 0_8 IF (COMPRESSCB) 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 (COMPRESSCB) 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) IF (associated(id%IS1)) NB_INT=NB_INT+size(id%IS1) 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%BUFR)) NB_INT=NB_INT+size(id%BUFR) 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%PROCNODE)) NB_INT=NB_INT+size(id%PROCNODE) IF (associated(id%INTARR)) NB_INT=NB_INT+size(id%INTARR) 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_BEFORE_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_BEFORE_L0_OMP) IF (associated(id%IPOOL_AFTER_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_AFTER_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+size(id%DBLARR) IF (associated(id%RHSCOMP)) NB_CMPLX=NB_CMPLX+size(id%RHSCOMP) 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 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_SIZE ) USE SMUMPS_STATIC_PTR_M INTEGER, INTENT(IN) :: THE_SIZE REAL, INTENT(IN) :: THE_ADDRESS(THE_SIZE) CALL SMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE)) RETURN END SUBROUTINE SMUMPS_SET_TMP_PTR MUMPS_5.1.2/src/clr_type.F0000664000175000017500000000421213164366265015456 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE CMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE COMPLEX,POINTER,DIMENSION(:,:) :: Q,R INTEGER :: LRFORM,K,M,N,KSVD LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT,KEEP8,IS_FACTOR) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER(8) :: KEEP8(150) INTEGER :: MEM 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 KEEP8(70) = KEEP8(70) + int(MEM,8) IF (.NOT.IS_FACTOR) THEN KEEP8(71) = KEEP8(71) + int(MEM,8) ENDIF 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, NB_BLR, KEEP8, IS_FACTOR) INTEGER, INTENT(IN) :: NB_BLR TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: I IF (NB_BLR.GT.0) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=1, NB_BLR CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8, IS_FACTOR) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE CMUMPS_LR_TYPE MUMPS_5.1.2/src/mumps_metis_int.c0000664000175000017500000000240713164366240017103 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/src/zfac_b.F0000664000175000017500000002012313164366265015060 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_FAC_B(N, NSTEPS, & A, LA, IW, 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,INTARR,DBLARR, & root, NELT, FRTPTR, FRTELT, COMM_LOAD, & ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, & DKEEP,PIVNUL_LIST,LPN_LIST & ,LRGROUPS & ) USE ZMUMPS_LOAD USE ZMUMPS_FAC_PAR_M IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER(8) :: LA INTEGER N,NSTEPS,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA COMPLEX(kind=8) A(LA) DOUBLE PRECISION RINFO(40) INTEGER LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER BUFR( LBUFR ) INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) INTEGER LRGROUPS(N) DOUBLE PRECISION CNTL1 INTEGER ICNTL(40) INTEGER INFO(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(LIW), 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(3*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 MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE DOUBLE PRECISION UULOC INTEGER LP, MPRINT INTEGER NSTK,PTRAST, NBPROCFILS INTEGER PIMASTER, PAMASTER LOGICAL PROK DOUBLE PRECISION ZERO, ONE DATA ZERO /0.0D0/ DATA ONE /1.0D0/ INTRINSIC int,real,log INTEGER IERR INTEGER NTOTPV, NTOTPVTOT, NMAXNPIV INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT KEEP(41)=0 KEEP(42)=0 NSTEPS = 0 LP = ICNTL(1) MPRINT = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) UULOC = CNTL1 IF (UULOC.GT.ONE) UULOC=ONE IF (UULOC.LT.ZERO) UULOC=ZERO IF (KEEP(50).NE.0.AND.UULOC.GT.0.5D0) THEN UULOC = 0.5D0 ENDIF PIMASTER = 1 NSTK = PIMASTER + KEEP(28) NBPROCFILS = NSTK + 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(67) = LRLUS KEEP8(68) = LRLUS KEEP8(69) = LRLUS KEEP8(70) = LRLUS KEEP8(71) = LRLUS IPTRLU = LRLU NTOTPV = 0 NMAXNPIV = 0 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))), SLAVEF ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF CALL ZMUMPS_FAC_PAR(N,IW,LIW,A,LA,IW1(NSTK),IW1(NBPROCFILS), & NFSIZ,FILS,STEP,FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & INFO(11), NTOTPV, NMAXNPIV, 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,NSTEPS,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) & ) 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 ENDIF KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(31), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) KEEP8(68) = LA - KEEP8(68) KEEP8(69) = LA - KEEP8(69) KEEP(89) = NTOTPV KEEP(246) = NMAXNPIV INFO(23) = KEEP(89) 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 in mc51d 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 in mc51d NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(31), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), INFO(25), RINFO(2), RINFO(3) 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/ & ' --- (25) NUMBER OF ENTRIES IN FACTORS =',I15/ & ' RINFO(2) OPERATIONS DURING NODE ASSEMBLY =',1PD10.3/ & ' -----(3) OPERATIONS DURING NODE ELIMINATION =',1PD10.3) END SUBROUTINE ZMUMPS_FAC_B MUMPS_5.1.2/src/cfac_front_LDLT_type1.F0000664000175000017500000004510413164366265017707 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NNEG, NPVW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS & , LRGROUPS & ) 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 !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR, NNEG, NPVW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL UU, SEUIL COMPLEX A( LA ) INTEGER, TARGET :: IW( LIW ) 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 REAL MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL LOGICAL LASTBL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL,ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok INTEGER :: OMP_NUM COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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 IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU SEUIL_LOC = SEUIL ENDIF PIVOT_OPTION = KEEP(468) 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(BEGS_BLR) 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 (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 IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTBL = .FALSE. IF (KEEP(201).EQ.1) THEN IDUMMY = -8765 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 PIVOT_OPTION = 3 CNT_NODES = CNT_NODES + 1 CALL INIT_STATS_FRONT(NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL INIT_STATS_FRONT(-NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1FR) ENDIF IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL CMUMPS_FAC_I_LDLT(NFRONT,NASS,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEG, 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IF (IFLAG.LT.0) GOTO 500 IF(KEEP(109).GT. 0) THEN IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE & +IW(IOLDPS+5+XSIZE) PIVNUL_LIST(KEEP(109)) = IW(IWPOSP2) ENDIF ENDIF IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN NPVW = NPVW + PIVSIZ IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) 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), & KEEP(253), & PIVOT_OPTION, IEND_BLR & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. (.NOT. COMPRESS_PANEL) .OR. & (KEEP(485).EQ.0) & ) & ) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,IEND_BLR,INODE,A,LA, & LDA, POSELT, & KEEP,KEEP8, & PIVOT_OPTION, .FALSE.) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,NASS,INODE,A,LA, & LDA, POSELT, & KEEP,KEEP8, PIVOT_OPTION, .TRUE.) ELSE CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 1, 1) NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(8), KEEP(477) & ) IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V',1) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR,'V', & NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 IF (COMPRESS_CB) THEN CALL CMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, NPARTSCB+NPARTSASS, & BEGS_BLR, NPARTSCB+NPARTSASS, NPARTSASS, & DKEEP(8), NASS, NFRONT-NASS, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, STEP_STATS(INODE), 1, & .FALSE., 0, KEEP(484)) END IF CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NFRONT-NASS, & KEEP(50), INODE, NASS-NPIV ) CALL STATS_COMPUTE_FLOP_FRONT_TYPE1(NFRONT, NASS, NPIV, & KEEP(50), INODE) LOC_LR_MODULE_TIME = dble(TTOT2-TTOT1)/dble(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (COMPRESS_PANEL) THEN IF ( PIVOT_OPTION.NE.3 & ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_FACTO_NIV1" CALL MUMPS_ABORT() ENDIF ELSE 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) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 490 CONTINUE write(*,*) 'Allocation problem in BLR routine & CMUMPS_FAC_FRONT_LDLT_TYPE1: ', & 'not enough memory? memory requested = ' , IERROR 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC1_LDLT END MODULE CMUMPS_FAC1_LDLT_M MUMPS_5.1.2/src/cana_reordertree.F0000664000175000017500000012340513164366264017146 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & 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 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(40) 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)), & SLAVEF))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)), & SLAVEF))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)), & SLAVEF))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)), & SLAVEF))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)),SLAVEF))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)),SLAVEF)))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)),SLAVEF)))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, & 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 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(40) 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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),SLAVEF) 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)),SLAVEF) 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)),SLAVEF))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)),SLAVEF) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE WRITE(*,*)ID,': INODE -> ',INODE,'DF =', & CUR_DEPTH_FIRST_RANK CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & SLAVEF))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & SLAVEF))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.1.2/src/sfac_b.F0000664000175000017500000002020713164366262015051 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_FAC_B(N, NSTEPS, & A, LA, IW, 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,INTARR,DBLARR, & root, NELT, FRTPTR, FRTELT, COMM_LOAD, & ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, & DKEEP,PIVNUL_LIST,LPN_LIST & ,LRGROUPS & ) USE SMUMPS_LOAD USE SMUMPS_FAC_PAR_M IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER(8) :: LA INTEGER N,NSTEPS,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA REAL A(LA) REAL RINFO(40) INTEGER LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER BUFR( LBUFR ) INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) INTEGER LRGROUPS(N) REAL CNTL1 INTEGER ICNTL(40) INTEGER INFO(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(LIW), 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(3*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 MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE REAL UULOC INTEGER LP, MPRINT INTEGER NSTK,PTRAST, NBPROCFILS INTEGER PIMASTER, PAMASTER LOGICAL PROK REAL ZERO, ONE DATA ZERO /0.0E0/ DATA ONE /1.0E0/ INTRINSIC int,real,log INTEGER IERR INTEGER NTOTPV, NTOTPVTOT, NMAXNPIV INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT KEEP(41)=0 KEEP(42)=0 NSTEPS = 0 LP = ICNTL(1) MPRINT = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) UULOC = CNTL1 IF (UULOC.GT.ONE) UULOC=ONE IF (UULOC.LT.ZERO) UULOC=ZERO IF (KEEP(50).NE.0.AND.UULOC.GT.0.5E0) THEN UULOC = 0.5E0 ENDIF PIMASTER = 1 NSTK = PIMASTER + KEEP(28) NBPROCFILS = NSTK + 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(67) = LRLUS KEEP8(68) = LRLUS KEEP8(69) = LRLUS KEEP8(70) = LRLUS KEEP8(71) = LRLUS IPTRLU = LRLU NTOTPV = 0 NMAXNPIV = 0 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))), SLAVEF ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF CALL SMUMPS_FAC_PAR(N,IW,LIW,A,LA,IW1(NSTK),IW1(NBPROCFILS), & NFSIZ,FILS,STEP,FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & INFO(11), NTOTPV, NMAXNPIV, 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,NSTEPS,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) & ) 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 ENDIF KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(31), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) KEEP8(68) = LA - KEEP8(68) KEEP8(69) = LA - KEEP8(69) KEEP(89) = NTOTPV KEEP(246) = NMAXNPIV INFO(23) = KEEP(89) 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 in mc51d 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 in mc51d NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(31), 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), INFO(25), RINFO(2), RINFO(3) 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/ & ' --- (25) NUMBER OF ENTRIES IN FACTORS =',I15/ & ' RINFO(2) OPERATIONS DURING NODE ASSEMBLY =',1PD10.3/ & ' -----(3) OPERATIONS DURING NODE ELIMINATION =',1PD10.3) END SUBROUTINE SMUMPS_FAC_B MUMPS_5.1.2/src/csol_fwd_aux.F0000664000175000017500000013771413164366264016327 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, III, 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_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, III, LEAF, NBFIN, LRHSCOMP INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 40 ), 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 ) #if defined(RHSCOMP_BYROWS) COMPLEX RHSCOMP( NRHS, LRHSCOMP ) #else COMPLEX RHSCOMP( LRHSCOMP, NRHS ) #endif 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 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 DOUBLE PRECISION :: TIME_TMP 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 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'Internal error 41r2 : Pool is too small.' CALL MUMPS_ABORT() END IF END IF 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))) #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) = & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + & WCB(PLEFTWCB+I-1) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) = & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) #endif ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF IF ( PTRICB(STEP(FINODE)) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'Internal error 41r2 : Pool is too small.' CALL MUMPS_ABORT() END IF ENDIF END IF 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 + (NPIV + NCV) * NRHS_B 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 IF (KEEP(201).GT.0) 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 APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201).EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE #endif CALL cgemm( 'N', 'N', NCV, NRHS_B, NPIV, ALPHA, & A(APOS), NCV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE #endif CALL cgemm( 'T', 'N', NCV, NRHS_B, NPIV, ALPHA, & A(APOS), NPIV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF IF (KEEP(201).GT.0) 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 - NPIV * NRHS_B PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & SLAVEF ) 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 IF (KEEP(350).EQ.0) THEN DO I = 1, NCV JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) DO K=1, NRHS_B #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + & WCB(PTRY+I-1+(K-1)*NCV) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PTRY+I-1+(K-1)*NCV) #endif ENDDO END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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)) #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) #endif & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF PTRICB(STEP(FINODE)) = & PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'INTERNAL Error 41r: Pool is too small.' 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, III, 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 - NCV * NRHS_B 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( INODE, & BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, III, 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, & MYROOT, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) USE CMUMPS_OOC USE CMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER INODE, LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, III, LEAF, NBFIN INTEGER MYROOT INTEGER INFO( 40 ), 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 ) COMPLEX RHS_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 #if defined(RHSCOMP_BYROWS) COMPLEX RHSCOMP(NRHS, LRHSCOMP) #else COMPLEX RHSCOMP(LRHSCOMP, NRHS) #endif COMPLEX VALPIV, A11, A22, A12, DETPIV LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP 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)) DOUBLE PRECISION TIME_TMP INTEGER JBDEB, JBFIN, NRHS_B INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, & IERR, & LIELL, JJ, & NELIM INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: POSWCB1, POSWCB2 INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, & JFIN, NBJ, NUPDATE_PANEL, & NBK, NBK_ini, TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB INTEGER LDAJ, LDAJ_ini, LDAJ_FIRST_PANEL INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY( 1 ) DUMMY(1)=1 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 (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) 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+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 ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSCOMP_TMP = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.0) THEN DO JJ = J1, J3 IFR8 = IFR8 + 1_8 DO K=JBDEB,JBFIN RHS_ROOT(IFR8+int(NPIV,8)*int(K-1,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif END DO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP+JJ-J1) #else & RHSCOMP(IPOSINRHSCOMP_TMP+JJ-J1,K) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error in SOLVE_NODE for Root node' CALL MUMPS_ABORT() END IF MYROOT = MYROOT - 1 IF ( MYROOT .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 GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF (KEEP(201).EQ.1) 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 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 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)) GO TO 260 END IF IF (KEEP(201).EQ.1) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV DO K=JBDEB, JBFIN IFR8 = PPIV_COURANT+int(K-JBDEB,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 #if defined(RHSCOMP_BYROWS) WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) #endif IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDDO IF (NCB.GT.0) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) #if defined(RHSCOMP_BYROWS) WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) RHSCOMP (K,IPOSINRHSCOMP) = ZERO #else WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP (IPOSINRHSCOMP,K) = ZERO #endif ENDDO ENDIF ENDDO ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.0) THEN !$ OMP_FLAG = NRHS_B.GT.4 .AND. .FALSE. !$OMP PARALLEL DO PRIVATE(J,IFR8,K) IF(OMP_FLAG) DO 130 JJ = J1, J3 J = IW(JJ) IFR8 = IFR_ini8 + int(JJ-J1+1,8) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) WCB(IFR8+(K-JBDEB)*NPIV) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else WCB(IFR8+(K-JBDEB)*NPIV) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif END DO 130 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(JJ,IFR8) IF(OMP_FLAG) DO K=JBDEB, JBFIN IFR8 = IFR_ini8 + (K-JBDEB)*NPIV DO JJ = J1, J3 #if defined(RHSCOMP_BYROWS) WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF IFR8 = PCB_COURANT - 1_8 IF (NPIV .LT. LIELL) THEN IFR_ini8 = IFR8 IF (KEEP(350).EQ.0) THEN !$OMP PARALLEL DO PRIVATE(J,IFR8,K,IPOSINRHSCOMP) IF(OMP_FLAG) DO 140 JJ = J3 + 1, J2 J = IW(JJ) IFR8 = IFR_ini8 + (JJ-J3) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(IPOSINRHSCOMP,K) #endif #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP)=ZERO #else RHSCOMP(IPOSINRHSCOMP,K)=ZERO #endif ENDDO 140 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J2-J3)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP) IF (OMP_FLAG) DO K=JBDEB, JBFIN IFR8 = IFR_ini8+(K-JBDEB)*NCB DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) #if defined(RHSCOMP_BYROWS) WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(IPOSINRHSCOMP,K) #endif #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP)=ZERO #else RHSCOMP(IPOSINRHSCOMP,K)=ZERO #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (KEEP(201).EQ.1) 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 (KEEP(50).NE.0) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), NPIV, WCB(PPIV_COURANT), & NPIV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1) THEN CALL ctrsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV ) #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), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm('L','L','N','N',NPIV, NRHS_B, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV) #if defined(MUMPS_USE_BLAS2) ENDIF #endif END IF END IF 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 ( NPIV .NE. 0 .AND. NUPDATE.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), & NPIV, WCB(PPIV_COURANT), 1, ONE, & WCB(PCB_COURANT), 1) ELSE #endif CALL cgemm('T', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), & LIELL, WCB(PPIV_COURANT), 1, & ONE, WCB(PCB_COURANT), 1 ) ELSE #endif CALL cgemm('N', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF END IF IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN IF (KEEP(350).EQ.0) THEN DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + int(K-JBDEB,8)*int(LD_WCBPIV,8) #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1) = #else RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1,K) = #endif & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN #if defined(RHSCOMP_BYROWS) !$ OMP_FLAG = (NPIV.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8,K) IF (OMP_FLAG) DO I=1,NPIV IFR8 = PPIV_COURANT + I-1 DO K=JBDEB,JBFIN RHSCOMP(K,IPOSINRHSCOMP+I-1) = & WCB(IFR8+(K-JBDEB)*LD_WCBPIV) ENDDO ENDDO !$OMP END PARALLEL DO #else !$ 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 #endif ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1) THEN LDAJ = TempNROW ELSE LDAJ = NPIV ENDIF APOS1 = APOS JJ = J1 IF (KEEP(201).EQ.1) THEN NBK = 0 ENDIF IF (KEEP(350).EQ.0) THEN DO IF(JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF(IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV #else RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV #endif END DO IF (KEEP(201).EQ.1) 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) THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1) 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 DO K=JBDEB, JBFIN POSWCB1 = IFR8+int(K-JBDEB,8)*int(LD_WCBPIV,8) POSWCB2 = POSWCB1+1_8 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #endif END DO IF (KEEP(201).EQ.1) 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 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1) 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 ) #if defined(RHSCOMP_BYROWS) RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = & WCB( IFR8 ) * VALPIV #else RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV #endif IF (KEEP(201).EQ.1) 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) THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1) 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #endif IF (KEEP(201).EQ.1) 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 ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF END IF IF (KEEP(201).GT.0) 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 END IF FPERE = DAD(STEP(INODE)) IF ( FPERE .EQ. 0 ) THEN MYROOT = MYROOT - 1 PLEFTWCB = PLEFTWCB - LIELL *NRHS_B IF ( MYROOT .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 GO TO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 IF (KEEP(350).EQ.0) THEN !$ OMP_FLAG = .FALSE. !$OMP PARALLEL DO PRIVATE(K,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) DO 190 I = 1, NUPDATE IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & RHSCOMP( K, IPOSINRHSCOMP_TMP ) #else RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) #endif & + WCB(PCB_COURANT + I-1 +(K-JBDEB)*LD_WCBCB) ENDDO 190 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NUPDATE*(JBFIN-JBDEB+1) .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 IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & RHSCOMP( K, IPOSINRHSCOMP_TMP ) #else RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) #endif & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE IF ( PTRICB(STEP(INODE)) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 ENDIF END IF ELSE PTRICB(STEP( INODE )) = -1 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 ENDIF 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)), SLAVEF), & 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, III, 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 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) GOTO 260 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, III, 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 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) GOTO 260 END IF END DO END IF PLEFTWCB = PLEFTWCB - LIELL*NRHS_B 270 CONTINUE RETURN 260 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_SOLVE_NODE RECURSIVE SUBROUTINE CMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, III, 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, III, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 40 ), 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) #if defined(RHSCOMP_BYROWS) COMPLEX RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX RHSCOMP(LRHSCOMP,NRHS) #endif LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN DOUBLE PRECISION :: TIME_TMP 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 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, III, 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 MUMPS_5.1.2/src/sfac_process_blocfacto_LDLT.F0000664000175000017500000010606213164366263021146 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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_OOC USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_FAC_LR USE SMUMPS_ANA_LR USE SMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mumps_headers.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ), 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), 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 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL, LD_BLOCFACTO INTEGER(8) LAELL, POSBLOCFACTO INTEGER(8) POSELT 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 INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW LOGICAL LASTBL INTEGER SRC_DESCBAND LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED REAL ONE,ALPHA PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPivDummy LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRELAY_INFO LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR LOGICAL :: SEND_LR INTEGER :: XSIZE, CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: SEND_LR_INT, 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 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL 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 INTEGER T1, T2, COUNT_RATE, LWORK REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, MY_NUM 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF 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 ( SEND_LR ) THEN LAELL = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LAELL = int(NPIV,8) * int(NCOL,8) ENDIF IF ( NPIV.GT.0 ) THEN IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS, IERROR) IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN SMUMPS_PROCESS_SYM_BLOCFACTO, & REAL WORKSPACE TOO SMALL" GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress SMUMPS_PROCESS_SYM_BLOCFACTO,", & " LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL-LRLUS,IERROR) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN SMUMPS_PROCESS_SYM_BLOCFACTO, & INTEGER WORKSPACE TOO SMALL" IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(70) = KEEP8(70) - LAELL KEEP8(71) = KEEP8(71) - LAELL ENDIF KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLUS) IF ( NPIV.EQ.0 ) THEN IPIV = 1 LD_BLOCFACTO = NPIV+NELIM ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR ) 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_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1))) ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2)) CALL SMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, KEEP(470), & BEGS_BLR_LM(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 SRC_DESCBAND = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTRIST(STEP(INODE))+XXNBPR)) DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) #else DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) POSELT = PTRAST(STEP(INODE)) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) ELSE CALL SMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS) 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 PIVI = abs(IW(IPIV+I-1)) 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(IPOS), NCOL1, A(KPOS), NCOL1) ENDDO IF (.NOT.SEND_LR) 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 (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T1) ENDIF CALL strsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A(POSELT+int(NPIV1,8)), NCOL1 ) IF (KEEP(486) .GT. 0) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_TRSM_TIME = ACC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF IF (.NOT.SEND_LR) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 DO I = 1, NROW1 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = & A(LPOS: LPOS+int(NPIV-1,8)) LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF LPOS = POSELT + int(NPIV1,8) DPOS = POSBLOCFACTO I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(IPIV+I-1) .GT. 0) THEN A11 = ONE/A(DPOS) CALL sscal( NROW1, A11, A(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 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A11*A(LPOS1)+A12*A(LPOS1+1_8) MULT2 = A12*A(LPOS1)+A22*A(LPOS1+1_8) A(LPOS1) = MULT1 A(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 IF (SEND_LR) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 ENDIF IF (NPIV.GT.0) THEN IF (NROW1.LE.0) CALL MUMPS_ABORT() IF (SEND_LR) 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 (KEEP(489).EQ.1) 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 ELSE CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_MASTER ENDIF CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL) 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 CALL SMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), & .TRUE., .TRUE., .TRUE., NPARTSASS_MASTER, & 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)) write(6,*) 'ERROR 2 allocate temporary BLR blocks during', & ' SMUMPS_PROCESS_SYM_BLOCFACTO', IERROR GOTO 700 ENDIF CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS)) CALL SYSTEM_CLOCK(T1) MY_NUM=0 #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, DKEEP(8), KEEP(473), BLR_LS, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #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. & ( .NOT. SEND_LR .OR. (NPIV.EQ.0) .OR. & (KEEP(485).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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN IF (SEND_LR) THEN IF (NELIM.GT.0) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL sgemm('N','N', NELIM,NROW1,NPIV,ALPHA, & A(UPOS),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ENDIF #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(MY_NUM) !$ MY_NUM = OMP_GET_THREAD_NUM() #endif CALL SMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL1, NROW1, & POSBLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM+1, BLR_LM, NPIV1, & BEGS_BLR_LS, NB_BLR_LS+1, BLR_LS, 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR(1:MAXI_CLUSTER,MY_NUM*MAXI_CLUSTER+1), & MAXI_CLUSTER, & KEEP(481), DKEEP(8), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_UPDT_TIME = ACC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_LS, & 0, NPARTSCB, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, & .FALSE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS, & CURRENT_BLR, 'V', NCOL1, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (KEEP(201).eq.1) 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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF ENDIF CALL DEALLOC_BLR_PANEL (BLR_LM, NB_BLR_LM, KEEP8, .FALSE.) DEALLOCATE(BLR_LM) IF (NSLAVES_PREC.GT.0) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL,BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF ELSE LPOS2 = POSELT + int(NPIV1,8) UPOS = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) CALL sgemm('N','N', NCOL-NPIV,NROW1,NPIV,ALPHA,A(UPOS),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) DPOS = POSELT + int(NCOL1 - NROW1,8) 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( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A(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( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, ONE, & A( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO 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. SEND_LR ) THEN LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) 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 ) CALL SMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & SEND_LR, BLR_LS, IPANEL, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 defined(IBC_TEST) WRITE(*,*) MYID,":Send2slave worked" #endif 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 ( NPIV.GT. 0 .AND. SEND_LR ) THEN IF (NSLAVES_PREC.GT.0) THEN IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8, .TRUE.) ENDIF LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( NPIV .NE. 0 ) THEN IF (allocated(UIP21K)) DEALLOCATE( UIP21K ) ENDIF IOLDPS = PTRIST(STEP(INODE)) IF (LASTBL) THEN IF (KEEP(486).NE.0) THEN IF (SEND_LR) 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)), SLAVEF ) 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 (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN CALL SMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, & BEGS_BLR_COL, NB_BLR_COL, NPARTSASS_MASTER, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., 0, KEEP(484)) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 (SEND_LR) 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, .TRUE.) 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 (KEEP(489).EQ.1) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if defined(IBC_TEST) write(6,*) MYID,' :Exiting SMUMPS_PROCESS_SYM_BLOCFACTO for &INODE=', INODE #endif RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.1.2/src/dmumps_ooc.F0000664000175000017500000036106213164366264016012 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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 #if ! defined (OOC_DEBUG) PTRFAC(STEP_OOC(INODE))=-777777_8 #endif 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 #if ! defined (OOC_DEBUG) PTRFAC(STEP_OOC(INODE))=-777777_8 #endif 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' 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))), & SLAVEF_OOC ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & SLAVEF_OOC ) 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)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),SLAVEF_OOC).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)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),SLAVEF_OOC).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) 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 #if ! defined(TEMP_VERSION_TO_FORCE_DATA_REINIT) & .OR. KEEP_OOC(50).NE.0 #endif & ) 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 #if ! defined(TEMP_VERSION_TO_FORCE_DATA_REINIT) & .OR. KEEP_OOC(50).NE.0 #endif & ) 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_STRUC_STORE_FILE_NAME' 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) & WRITE(ICNTL1,*) & 'PB allocation in DMUMPS_STRUC_STORE_FILE_NAME' 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) & WRITE(ICNTL1,*) & 'PB allocation in DMUMPS_OOC_OPEN_FILES_FOR_SOLVE' 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) 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.1.2/src/stype3_root.F0000664000175000017500000012660513164366263016140 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_ASS_ROOT( NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) IMPLICIT NONE 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 IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON DO J = 1, NCOL_SON-NSUPCOL VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) = & VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'smumps_root.h' INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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))) 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, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) NBPROCFILS( STEP(IROOT) ) = -1 #if ! defined(NO_XXNBPR) KEEP(121) = -1 #endif IF (IFLAG.LT.0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT)) - 1 #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) - 1 #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN #endif 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(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 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, A( PTRR( STEP(ISON)) + 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, A( PTRR( STEP(ISON)) + 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) 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_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, A( PTRR(STEP(ISON)) + 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, root%RG2L_COL, & 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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 ) IMPLICIT NONE INCLUDE 'smumps_root.h' 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 ) 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 & ) IMPLICIT NONE INCLUDE 'smumps_root.h' 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 ) IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE ( SMUMPS_ROOT_STRUC ):: root INTEGER N, IROOT, INFO(40), KEEP(500) INTEGER FILS( N ) INTEGER INODE, I, allocok IF ( associated( root%RG2L_ROW ) ) DEALLOCATE( root%RG2L_ROW ) IF ( associated( root%RG2L_COL ) ) DEALLOCATE( root%RG2L_COL ) 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 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, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IMPLICIT NONE INCLUDE 'smumps_root.h' 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 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 ) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N ) 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 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 RETURN ENDIF 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, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, 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 RETURN END SUBROUTINE SMUMPS_ROOT_ALLOC_STATIC SUBROUTINE SMUMPS_ASM_RHS_ROOT & ( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) IMPLICIT NONE INCLUDE 'smumps_root.h' 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 MUMPS_5.1.2/src/dbcast_int.F0000664000175000017500000000276113164366263015754 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/smumps_lr_data_m.F0000664000175000017500000005411613164366263017171 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_PANEL_LORU, & SMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & SMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & SMUMPS_BLR_RETRIEVE_PANEL_L, & SMUMPS_BLR_RETRIEVE_PANEL_LORU, & SMUMPS_BLR_DEC_AND_TRYFREE_L, & SMUMPS_BLR_TRY_FREE_PANEL, & SMUMPS_BLR_FREE_ALL_PANELS, & SMUMPS_BLR_FREE_PANEL TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(lrb_type), pointer :: LRB_PANEL(:) END TYPE blr_panel_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 INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333) 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) 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) ENDDO RETURN END SUBROUTINE SMUMPS_BLR_INIT_MODULE SUBROUTINE SMUMPS_BLR_END_MODULE(INFO1, KEEP8, IS_FACTOR) INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: I, ILOOP IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF ILOOP=0 DO I=1, size(BLR_ARRAY) ILOOP= ILOOP+1 IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U)) THEN IF (INFO1 .GE.0) THEN WRITE(*,*) "Internal error 2 in MUMPS_BLR_END_MODULE ", & " IWHANDLER=", I CALL MUMPS_ABORT() ELSE CALL SMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, IS_FACTOR) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE SMUMPS_BLR_END_MODULE SUBROUTINE SMUMPS_BLR_INIT_FRONT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error in SMUMPS_BLR_INIT_FRONT ", & NB_PANELS ENDIF CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) 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 RETURN 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) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) ELSE ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (associated(BEGS_BLR_COL)) THEN INFO(2)=size(BEGS_BLR_L)+size(BEGS_BLR_COL) ELSE INFO(2)=size(BEGS_BLR_L) ENDIF RETURN ENDIF ELSE IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(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_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM.and.IsT2.and.IsSLAVE.and. & associated(BEGS_BLR_COL)) THEN INFO(2)=NB_PANELS+size(BEGS_BLR_L)+size(BEGS_BLR_COL) ELSE IF (IsSYM) THEN INFO(2)=NB_PANELS+size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+size(BEGS_BLR_L) ENDIF RETURN 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 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 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_INIT_FRONT SUBROUTINE SMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, & KEEP8, IS_FACTOR) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) THEN RETURN 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) THEN WRITE(*,*) " Internal Error 2 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, IS_FACTOR) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF ENDIF ENDDO NULLIFY(THEPANEL%LRB_PANEL) 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) THEN WRITE(*,*) " Internal Error 2 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, IS_FACTOR) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF ENDIF ENDDO NULLIFY(THEPANEL%LRB_PANEL) IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF ENDIF IF (.NOT. associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER CALL MUMPS_ABORT() ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) 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 CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) 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 ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 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_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_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_PANEL_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_RETRIEVE_PANEL_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_RETRIEVE_PANEL_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_RETRIEVE_PANEL_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_RETRIEVE_PANEL_L 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", & "IPANEL=", IPANEL 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", & "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_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF 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 ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 2 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(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_U(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT - 1 ENDIF RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE SMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8, IS_FACTOR) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR 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, IS_FACTOR) RETURN END SUBROUTINE SMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE SMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE SMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE SMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO 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 (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_BLR_FREE_ALL_PANELS SUBROUTINE SMUMPS_BLR_FREE_PANEL( IWHANDLER, LORU, IPANEL, & KEEP8, IS_FACTOR ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: LORU INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF (LORU.EQ.0.or.LORU.EQ.1) THEN IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ELSE 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 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, IS_FACTOR) DEALLOCATE(THEPANEL%LRB_PANEL) ENDIF NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE SMUMPS_BLR_FREE_PANEL END MODULE SMUMPS_LR_DATA_M MUMPS_5.1.2/src/sfac_process_maprow.F0000664000175000017500000014243213164366262017700 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif IMPLICIT NONE INCLUDE 'smumps_root.h' #if ! defined(NO_FDM_MAPROW) #endif TYPE (SMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) 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 ) 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 COMPRESSCB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE, TYPESPLIT INTEGER KEEP253_LOC #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 IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE_PERE)), & SLAVEF) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in SMUMPS_MAPLIG' 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)), & SLAVEF ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) write(LP,*) MYID, & ' : PB allocation NBROW in SMUMPS_MAPLIG' 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)), & SLAVEF) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 7 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO #endif ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 9 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO_SYM #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM 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( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) 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 COMPRESSCB=(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 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(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & A(PTRAST(STEP(ISON))), I, PDEST, PDEST_MASTER, & COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, COMPRESSCB, & KEEP253_LOC ) 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF ITYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), SLAVEF) 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, MYID, COMM, KEEP,KEEP8, DKEEP,ITYPE & ) 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 &) 600 CONTINUE DEALLOCATE(PERM) 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 40 ), 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 INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ) 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 NBPROCFILS( KEEP(28) ) 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 ) 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) :: APOS, POSROW, ASIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL COMPRESSCB INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM 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)), & SLAVEF ) 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(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ': PB allocation PERM in SMUMPS_MAPLIG_FILS_NIV1' 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( 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)) 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 COMPRESSCB=(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 DECR=1 NBPROCFILS(STEP(INODE_PERE)) = & NBPROCFILS(STEP(INODE_PERE)) - DECR NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR #if ! defined(NO_XXNBPR) IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE_PERE)), & IW(PTLUST(STEP(INODE_PERE))+XXNBPR)) IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXNBPR)) #endif DO II = 1,NROWS_TO_STACK IROW_SON=PERM(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 (COMPRESSCB) THEN IF (NELIM.EQ.0) THEN POSROW = PAMASTER(STEP(ISON)) + & int(IROW_SON,8)*int(IROW_SON-1,8)/2_8 ELSE POSROW = PAMASTER(STEP(ISON)) + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ENDIF ELSE POSROW = PAMASTER(STEP(ISON)) + & 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 CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF) ENDDO IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (COMPRESSCB) THEN POSROW = PAMASTER(STEP(ISON)) & + 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 = PAMASTER(STEP(ISON)) + & 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).GT. 0 ) THEN CALL SMUMPS_COMPUTE_MAXPERCOL( & A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253), & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB, & NELIM+NBROW(1)) ELSE CALL SMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF CALL SMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXNBPR)) IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 #endif & ) 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 ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE_PERE)), & IW(PTLUST(STEP(INODE_PERE))+XXNBPR)) IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 #endif & ) THEN CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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)) APOS = PAMASTER(STEP(ISON)) 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 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(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & A(APOS), I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & COMPRESSCB, KEEP(253)) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 SMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) 600 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(MAP) DEALLOCATE(PERM) DEALLOCATE(SLAVES_PERE) RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 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, NBPROCFILS, & 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL & ) USE SMUMPS_BUF, ONLY: SMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE SMUMPS_LOAD, ONLY : SMUMPS_LOAD_POOL_UPD_NEW_POOL INTEGER ICNTL(40) 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(inout) :: NBPROCFILS( KEEP(28) ) 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 INTEGER, intent(in) :: FILS(N) 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 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 LOGICAL :: COMPRESSCB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) #if ! defined(NO_XXNBPR) INTEGER :: INBPROCFILS_SON #endif 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 NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - DECR #if ! defined(NO_XXNBPR) IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR #endif IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR #if ! defined(NO_XXNBPR) IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR #endif 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 COMPRESSCB = (IW(ISTCHK+XXS).EQ.S_CB1COMP) CALL MUMPS_GETI8(SIZFR, IW(ISTCHK+XXR)) IF (IW(ISTCHK+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 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 ) 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 ) ENDIF ENDIF DO II = 1,NROWS_TO_STACK 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 ( COMPRESSCB ) THEN IF (NBCOLS - NROW .EQ. 0 ) THEN ITMP = IROW_SON POSROW = PTRAST(STEP(ISON))+ & int(ITMP,8) * int(ITMP-1,8) / 2_8 ELSE ITMP = IROW_SON + NBCOLS - NROW POSROW = PTRAST(STEP(ISON)) & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ENDIF ELSE POSROW = PTRAST(STEP(ISON)) + 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 CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.COMPRESSCB).AND.(IS_ofType5or6) ) THEN CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) ENDIF ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV 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) & .OR. & ( (KEEP(50).NE.0).and. (.NOT.COMPRESSCB) ) & ) & ) THEN CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - & NROWS_TO_STACK #if ! defined(NO_XXNBPR) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK #endif EXIT ELSE CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - 1 #if ! defined(NO_XXNBPR) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 #endif ENDIF ENDIF ENDDO IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (COMPRESSCB) THEN WRITE(*,*) "Error 1 in PARPIV/SMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = PTRAST(STEP(ISON))+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 .NE. 0 ) THEN CALL SMUMPS_COMPUTE_MAXPERCOL( & A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, LMAP_LOC-NBROW(1)+1-KEEP253_LOC, & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB,ITMP) ELSE CALL SMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF CALL SMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB #if ! defined(NO_XXNBPR) 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 #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL( NBPROCFILS(STEP(ISON)), & IW(INBPROCFILS_SON) ) IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN #endif 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 SMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, & ISTCHK_LOC, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL( NBPROCFILS(STEP(IFATH)), & IW(PTLUST(STEP(IFATH))+XXNBPR) ) IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(IFATH)) .EQ. 0 #endif & ) THEN CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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.1.2/src/cfac_mem_compress_cb.F0000664000175000017500000002770113164366264017755 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INCLUDE 'mumps_headers.h' 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 SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE CMUMPS_SIZEFREEINREC 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) IMPLICIT NONE INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER N,LIW,KEEP28, & IWPOS,IWPOSCB,KEEP216,XSIZE INTEGER(8) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER IW(LIW),PTRIST(KEEP28), & STEP(N), PIMASTER(KEEP28) COMPLEX 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 INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE INTEGER IXXP 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 IF ( STATE_NEXT .NE. S_FREE .AND. & (KEEP216.EQ.3.OR. & (STATE_NEXT .NE. S_NOLCBNOCONTIG .AND. & STATE_NEXT .NE. S_NOLCBCONTIG .AND. & STATE_NEXT .NE. S_NOLCBNOCONTIG38 .AND. & STATE_NEXT .NE. S_NOLCBCONTIG38))) THEN CALL CMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) 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 (RSIZE2SHIFT .NE. 0_8) THEN IF (PTRAST(STEP(INODE)).EQ.RCURRENT) & PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT IF (PAMASTER(STEP(INODE)).EQ.RCURRENT) & PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT 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 IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN IF ( KEEP216.eq.3) THEN WRITE(*,*) "Internal error 2 in CMUMPS_COMPRE_NEW" ENDIF 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) 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) 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) ELSE 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 INODE=IW(ICURRENT+XXN) IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) IF (STATE_NEXT.EQ.S_NOLCBCONTIG.OR. & STATE_NEXT.EQ.S_NOLCBNOCONTIG) THEN IW(ICURRENT+XXS)=S_NOLCLEANED ELSE IW(ICURRENT+XXS)=S_NOLCLEANED38 ENDIF 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 MUMPS_5.1.2/src/dmumps_struc_def.F0000664000175000017500000000070613164366264017203 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zrank_revealing.F0000664000175000017500000000477713164366265017036 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), MPG KEEP(19)=0 RETURN END SUBROUTINE ZMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE ZMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL,KEEP,MPG,INFO) IMPLICIT NONE INTEGER KEEP(500), MPG, INFO(40), ICNTL(40) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 16 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 (ICNLT(9)=1) ' ENDIF ENDIF 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.1.2/src/mumps_size.h0000664000175000017500000000115313164366240016064 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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_INT *diff); #endif /* MUMPS_SIZE_H */ MUMPS_5.1.2/src/dfac_lastrtnelind.F0000664000175000017500000001750713164366263017326 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)),SLAVEF) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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( .FALSE.,MYID,N, IPOS_SON, & PTRAST(STEP(IN)), & 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.1.2/src/dsol_bwd_aux.F0000664000175000017500000011156413164366264016317 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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(40), 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 MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION RHSCOMP(NRHS,LRHSCOMP) #else DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) #endif 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 DOUBLE PRECISION :: TIME_TMP 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 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE DMUMPS_OOC 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(40), 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 MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION RHSCOMP(NRHS,LRHSCOMP) #else DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) #endif INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED 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(8) :: P_UPDATE, P_SOL_MAS 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_TMP, IPOSINRHSCOMP_PANEL DOUBLE PRECISION :: TIME_TMP INTEGER JBDEB, JBFIN, NRHS_B, allocok 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 MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE, dtrsv, dtrsm, dgemv, dgemm 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 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. FEUILLE) 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 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 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP) = W(POSWCB+1+JJ) #else RHSCOMP(IPOSINRHSCOMP,K) = W(POSWCB+1+JJ) #endif ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( KEEP(237).GT. 0 ) 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)), & SLAVEF) .eq. MYID ) THEN IF ( KEEP(237).GT. 0 ) 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 IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF (KEEP(201).GT.0) 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(IW( IPOS + 3 )) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 in 41S : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - LONG*NRHS_B .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 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + NPIV * NRHS_B PLEFTW = P_SOL_MAS + NROW_L * NRHS_B 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).EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE #endif CALL dgemm( 'T', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE #endif CALL dgemm( 'N', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF IF (KEEP(201).GT.0) 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 - NROW_L * NRHS_B 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 ) 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = W2(I) #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) #endif I = I+1 ENDDO ELSE DO JJ = J1,J2 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) + W2(I) #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) #endif 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) 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) 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 )) IF (KEEP(350).EQ.0) THEN DO K=JBDEB, JBFIN DO JJ = J1, J2 W(IFR8+JJ-J1+(K-JBDEB)*LIELL) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif END DO END DO ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*) "Internal error DMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR8 = IFR8 + 1 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(K,IPOSINRHSCOMP_TMP) #else W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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 ELSE WRITE(*,*) "Internal error DMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF IF ( KEEP(201).EQ.1 .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 (KEEP(350).EQ.0) THEN CALL dgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( PTWCB_PANEL + int(NBJ,8) ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ELSE IF (NCB_PANEL - NCB.NE. 0) THEN CALL dgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), & 1, ONE, & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF IF (NCB .NE. 0) THEN CALL dgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + NPIV ), & 1, ONE, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF ENDIF ENDIF IF (KEEP(350).eq.0) THEN CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (KEEP(350).eq.0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(PTWCB_PANEL+int(NBJ,8)),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else 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 ENDIF ENDIF IF (KEEP(350).eq.0) THEN CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF 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 IF (KEEP(350).EQ.0) THEN CALL dgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & W(PTRACB(STEP(INODE))), 1 ) ELSE CALL dgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE IF (KEEP(350).EQ.0) THEN CALL dgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, W(PTRACB(STEP(INODE))),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL dgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF END IF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL dtrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & W(PTRACB(STEP(INODE))),1) ELSE CALL dtrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL dtrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & W(PTRACB(STEP(INODE))),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL dtrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif 1234 CONTINUE IF (KEEP(201).GT.0) 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO I = 1, NPIV DO K=JBDEB,JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) #else RHSCOMP( IPOSINRHSCOMP_TMP , K ) = & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) #endif ENDDO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*)"Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF IN = INODE 200 IN = FILS(IN) IF (IN .GT. 0) GOTO 200 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, 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 ( KEEP(237).GT.0 ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( KEEP(237).GT.0 ) 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)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & SLAVEF ) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 IF (NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, FEUILLE, 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=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 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 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE DEALLOCATE(DEJA_SEND) RETURN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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.1.2/src/zana_aux.F0000664000175000017500000034510213164366265015451 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_ANA_F(N, NZ8, IRN, ICN, LIW8, IKEEP, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id) USE ZMUMPS_STRUC_DEF USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: IRN(NZ8) INTEGER, INTENT(IN) :: ICNTL(40) INTEGER, INTENT(INOUT) :: ICN(NZ8) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(INOUT) :: INFO(40), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) TYPE (ZMUMPS_STRUC) :: id INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE :: 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(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS #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 PIV(N) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL LOGICAL IDENT,SPLITROOT 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 ALLOCATE( IW (LIW8), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIW8,INFO(2)) GOTO 90 ENDIF ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( IPE(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 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 (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN WRITE (MP,99999) N, NZ8, LIW8, INFO(1) J8 = min(10_8,NZ8) IF (LDIAG.EQ.4) J8 = NZ8 IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) 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 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, ICN, IW(1), LIW8, & IPE, 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, SIZE_SCHUR, FRERE, FILS) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif 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, ICN, IW(1), LIW8, & IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265)) DEALLOCATE(IPQ8) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif INFO(8) = symmetry IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .LE. 1 ) 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( N, KEEP(50), NSLAVES, IORD, & symmetry, 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 IF(KEEP(95) .EQ. 2 .AND. IORD .EQ. 0) THEN IF (PROK) WRITE(MP,*) & 'WARNING: ZMUMPS_ANA_F AMD not available with ', & ' compressed ordering -> move to QAMD' IORD = 6 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(id%CNTL(4) .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,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) 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, ICN, PIV, & NCMP, IW(1), LIW8, IPE, PTRAR(1,2), IPQ8, & IWL1, FILS, IWFR8, & IERROR, KEEP, KEEP8, ICNTL) 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)=id%COLSCA(J) ENDDO DO J=1, N id%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, ICN, IW(1), LIW8, IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265)) DEALLOCATE(IPQ8) INFO(8) = symmetry 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 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 (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, IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR, 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) 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 IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, N, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, N, 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 CALL ZMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS) CALL ZMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW(1), & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW(1), & 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 (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(1), IWL1, IKEEP, & IKEEP(1,2), NCMPA, INFO, LP, LPOK) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW(1), IWL1, IKEEP, & IKEEP(1,2), NCMPA, INFO, LP, LPOK, KEEP(10)) 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) THEN CALL ZMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS) CALL ZMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .GE. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IWL1(1) = -1 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4(NCMP, NBBUCK, LIW8, IPE, & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP, PARENT) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE, & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ, FRERE, PARENT) 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 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 TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_QAMD(TOTEL,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE, IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT) DEALLOCATE(WTEMP) ELSE CALL MUMPS_ANA_H(NCMP, LIW8, IPE, IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL ZMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV,IKEEP(1,1),IKEEP(1,2)) 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 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF OPTIONS_METIS(1) = 0 #else OPT_METIS_SIZE = 40 OPT_METIS_SIZE = OPT_METIS_SIZE + 60 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF CALL METIS_SETDEFAULTOPTIONS(OPTIONS_METIS) OPTIONS_METIS(18) = 1 #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(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK, KEEP(10) ) 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(1), NUMFLAG, & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW(1), NUMFLAG, & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10)) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF #else ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW(1),FRERE(1), & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW(1),FRERE(1), & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10) ) 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 DEALLOCATE (OPTIONS_METIS) IF ( COMPRESS_SCHUR ) THEN CALL ZMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP(1,1),IKEEP(1,2), & LISTVAR_SCHUR, SIZE_SCHUR, FILS) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL ZMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV,IKEEP(1,1),IKEEP(1,2)) 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) & ) THEN DO K=1,N PTRAR(K,1) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (PTRAR(IKEEP(K,1),1).EQ.1) THEN GOTO 40 ELSE PTRAR(IKEEP(K,1),1) = 1 ENDIF ENDDO ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1) THEN IF ((KEEP(106)==1).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, ICN, IW(1), LIW8, & IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265)) DEALLOCATE(IPQ8) INFO(8) = symmetry ENDIF COMPRESS = 0 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. CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, LIW8, IPE, IWFR8, PTRAR(1,2), IW, & IWL1, WTEMP(N+1), & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, & PTRAR(1,3),IKEEP(1,1), LISTVAR_SCHUR, ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ELSE CALL ZMUMPS_ANA_J(N, NZ8, IRN, ICN, IKEEP, IW(1), & LIW8, IPE, & 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, IW, LIW8, IWFR8, IKEEP, & IKEEP(1,2), 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, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else IF (allocated(IPE)) DEALLOCATE(IPE) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF CALL ZMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, PTRAR, INFO(6), FILS, FRERE, & 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) 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(IKEEP(1,2), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP(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 .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) 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).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 CALL ZMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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 CALL ZMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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,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 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(IW)) DEALLOCATE(IW) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 9X, I8, I11, I12, I14) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I7, I12, I7, I12, I7)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) END SUBROUTINE ZMUMPS_ANA_F 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) 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 #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,INT,NR1 #else INTEGER DADI LOGICAL AMALG_TO_father_OK #endif AMALG_COUNT = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 NODE(I) = 1 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE 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 NODE(IF) = NODE(IF)+1 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 #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 AMALG_TO_father_OK = .TRUE. 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 INT = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT) = -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, MAXFAC, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER NSTEPS,MAXNPIV INTEGER MAXFR, MAXELIM, K50, MAXFAC INTEGER K5,K6,PANEL_SIZE,K253 INTEGER NE(NSTEPS), ND(NSTEPS) INTEGER ITREE, NFR, NELIM INTEGER LKJIB LKJIB = max(K5,K6) MAXFR = 0 MAXFAC = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 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 MAXFAC = max(MAXFAC, (2*NFR - NELIM)*NELIM ) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE MAXFAC = max(MAXFAC, NFR * NELIM) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF 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_ANA_O( N, NZ, MTRANS, PERM, & id, ICNTL, INFO) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(N) INTEGER, INTENT(INOUT) :: MTRANS INTEGER, INTENT(IN) :: ICNTL(40) INTEGER, INTENT(INOUT) :: INFO(40) 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 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)) IF (PROK) WRITE(MPRINT,101) 101 FORMAT(/'****** Preprocessing of original matrix '/) K50 = id%KEEP(50) SCALINGLOC = .FALSE. IF(id%KEEP(52) .EQ. -2) THEN IF(.not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(id%KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF(K50 .NE. 2) THEN IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' ENDIF ENDIF IF(.not.associated(id%A)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF 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 MTRANSLOC = 5 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 => id%IS1(N+1:2*N) STR_KER => id%IS1(2*N+1:3*N) CALL ZMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(2) 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 id%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 ) GOTO 410 ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (2*N+1)*id%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 ) GOTO 430 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 = id%IRN(K) J = id%JCN(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 = id%IRN(K) J = id%JCN(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(id%A)) THEN IF(abs(id%A(K)) .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 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 = id%IRN(K) J = id%JCN(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(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF K = 1_8 THEMIN = ZERO DO IF(THEMIN .NE. ZERO) EXIT THEMIN = abs(id%A(K)) K = K+1_8 ENDDO THEMAX = THEMIN DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(id%A(K)) .GT. THEMAX) THEN THEMAX = abs(id%A(K)) ELSE IF(abs(id%A(K)) .LT. THEMIN & .AND. abs(id%A(K)).GT. ZERO) THEN THEMIN = abs(id%A(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(id%A(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 CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N)) & - log(THEMIN) + ONE ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => id%IS1(3*N+1:4*N) IF(MTRANSLOC.NE.1) THEN CALL ZMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM,IPQ8(1)) ELSE CALL ZMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM) 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, 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 = id%JCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 id%JCN(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(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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( id%ROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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 id%KEEP(52) = -2 id%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) id%ROWSCA(J) = exp(S2(RSPOS+J8)) IF(id%ROWSCA(J) .EQ. ZERO) THEN id%ROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN id%COLSCA(J)= exp(S2(CSPOS+J8)) IF(id%COLSCA(J) .EQ. ZERO) THEN id%COLSCA(J) = ONE ENDIF ELSE id%COLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(id%COLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN id%COLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(id%COLSCA)) DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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( id%ROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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 id%KEEP(52) = -2 id%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 id%ROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(id%ROWSCA(J) .EQ. ZERO) THEN id%ROWSCA(J) = ONE ENDIF id%COLSCA(J)= id%ROWSCA(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) id%ROWSCA(I) = ONE / COLNORM id%COLSCA(I) = id%ROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. id%KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. id%KEEP(95) .EQ. 0) THEN MTRANS = 0 id%KEEP(95) = 1 GOTO 390 ELSE IF(id%KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN id%KEEP(95) = 3 ELSE id%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 => id%IS1(2*N+1:3*N) FLAG => id%IS1(3*N+1:4*N) PIV_OUT => id%IS1(4*N+1:5*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, & 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( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 & ) THEN IDENT = .TRUE. id%KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF id%KEEP(93) = INFO_SYM_MWM(4) id%KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN id%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 SUBROUTINE ZMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL ) IMPLICIT NONE INTEGER COMM, MYID, KEEP(500), INFO(40), ICNTL(40), INFOG(40) 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), 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) Storage of factors (REAL, estimated) =',I16/ & ' -- (4) Storage of factors (INT , 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/ & 'Percentage of memory relaxation (effective) =',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, 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 ) 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 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)), & 1_8) IF (KEEP(53).NE.0) THEN MAX_CUT = NFRONT K79 = 121_8*121_8 ELSE K79 = min(2000_8*2000_8,K79) 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 ) 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 ) 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 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_SON, NPIV_FATH 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 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 DO WHILE( IN > 0 ) IN = FILS( IN ) NPIV = NPIV + 1 END DO 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)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375)) 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 NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 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 IN_SON = INODE DO I = 1, NPIV_SON - 1 IN_SON = FILS( IN_SON ) END DO 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 ) 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 ) 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) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) 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 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) 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 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE 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 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 ((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 ELSE symmetry = 100 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 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_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(40) 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).GE.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, 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(INOUT) :: INFO(40) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN 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) IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO 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 DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE ZMUMPS_SORT_PERM SUBROUTINE ZMUMPS_ANA_N_PAR( id, PTRAR ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE include 'mpif.h' TYPE(ZMUMPS_STRUC), INTENT(IN), TARGET :: id INTEGER(8), INTENT(OUT), TARGET :: PTRAR(id%N,2) INTEGER :: IERR 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(1:id%N,2) allocate(IWORK2(id%N)) IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => PTRAR(1:id%N,1) IWORK2 => PTRAR(1:id%N,2) 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,1), id%N, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), id%N, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR, 2*id%N, MPI_INTEGER8, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE ZMUMPS_ANA_N_PAR SUBROUTINE ZMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(40),INFOG(40),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) DOUBLE PRECISION PEAK CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & ) 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.1.2/src/mumps_metis_int.h0000664000175000017500000000120413164366240017102 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/src/dend_driver.F0000664000175000017500000003156413164366266016135 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) 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%PROCNODE)) THEN DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) 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 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 -------------- C Receive buffer C -------------- IF ( associated( id%BUFR ) ) DEALLOCATE( id%BUFR ) NULLIFY( id%BUFR ) 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_AFTER_L0_OMP)) THEN DEALLOCATE(id%IPOOL_AFTER_L0_OMP) NULLIFY(id%IPOOL_AFTER_L0_OMP) END IF IF (associated(id%IPOOL_BEFORE_L0_OMP)) THEN DEALLOCATE(id%IPOOL_BEFORE_L0_OMP) NULLIFY(id%IPOOL_BEFORE_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%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 RETURN END SUBROUTINE DMUMPS_END_DRIVER MUMPS_5.1.2/src/cfac_lastrtnelind.F0000664000175000017500000001744013164366264017322 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)),SLAVEF) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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( .FALSE.,MYID,N, IPOS_SON, & PTRAST(STEP(IN)), & 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.1.2/src/cstatic_ptr_m.F0000664000175000017500000000173713164366264016500 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/dini_driver.F0000664000175000017500000001747513164366266016153 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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" 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 C Reception buffer initialized to zero NULLIFY(id%BUFR) C id%MAXIS1 = 0 C C id%INST_Number = -1 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) id%LSOL_loc=0 NULLIFY(id%SOL_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%IS1) NULLIFY(id%STEP) 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%PROCNODE) 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) 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_BEFORE_L0_OMP) NULLIFY(id%IPOOL_AFTER_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) 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.1.2/src/sana_aux_par.F0000664000175000017500000027547613164366263016322 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, POINTER :: WORK1(:), WORK2(:), & 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 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 CALL SMUMPS_DO_PAR_ORD(id, ord, WORK2) 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) 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%KEEP(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 CALL SMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), & NFSIZ(1), 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 CALL SMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), NFSIZ(1), & 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, WORKERS #if defined(parmetis) || defined(parmetis3) INTEGER :: I, COLOR, BASE 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, POINTER :: 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, POINTER :: 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(MUMPS_GETSIZE(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, POINTER :: 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(MUMPS_GETSIZE(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 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)) 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) 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, POINTER :: 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(MUMPS_GETSIZE(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 = .TRUE. 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 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) 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=1, TOPNODES(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 INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR)) 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 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)) 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)) 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 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 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)) 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)) 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 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1)) 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) 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 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)) ALLOCATE(RCVBUF(2*BUFSIZE)) ALLOCATE(PENDING(NPROCS), CPNT(NPROCS)) ALLOCATE(REQ(NPROCS)) 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)) 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 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_COPY_INT_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_COPY_INT_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_COPY_INT_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_COPY_INT_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_COPY_INT_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_COPY_INT_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_COPY_INT_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_COPY_INT_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_COPY_INT_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_COPY_INT_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_COPY_INT_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_COPY_INT_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.1.2/src/comp_tps_m.F0000664000175000017500000000070113164366265015774 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE CMUMPS_TPS_M_RETURN MUMPS_5.1.2/src/zsol_aux.F0000664000175000017500000010521213164366265015503 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) COMPLEX(kind=8) W(N), X(N) DOUBLE PRECISION, intent(inout) :: EST 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) 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) 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 ) 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 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) 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) 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) 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)) 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)) 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) # if defined(RHSCOMP_BYROWS) COMPLEX(kind=8), INTENT(INOUT) :: RHSCOMP(NRHS,LRHSCOMP) # else COMPLEX(kind=8), INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) # endif INTEGER :: LD_W, FIRST_ROW_W COMPLEX(kind=8) :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT #if defined(RHSCOMP_BYROWS) !$OMP PARALLEL DO PRIVATE (ISHIFT, K), IF !$OMP& ((NBROWS) * (JBFIN-JBDEB+1) > KEEP(363)) DO JJ = 0, NBROWS-1 ISHIFT = FIRST_ROW_W+JJ DO K = JBDEB, JBFIN RHSCOMP(K,FIRST_ROW_RHSCOMP+JJ) = & W(ISHIFT+LD_W*(K-JBDEB)) END DO END DO !$OMP END PARALLEL DO #else !$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 #endif 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) # if defined(RHSCOMP_BYROWS) COMPLEX(kind=8), INTENT(INOUT) :: RHSCOMP(NRHS,LRHSCOMP) # else COMPLEX(kind=8), INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) # endif COMPLEX(kind=8) :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSCOMP_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSCOMP #if defined(RHSCOMP_BYROWS) !$OMP PARALLEL DO PRIVATE(K,ISHIFT,IPOSINRHSCOMP), IF !$OMP& ((JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>KEEP(363)) DO JJ = J1, J2-KEEP(253) ISHIFT = FIRST_ROW_W+JJ-J1 IPOSINRHSCOMP = abs(POSINRHSCOMP_BWD(IW(JJ))) DO K=JBDEB, JBFIN W(ISHIFT+(K-JBDEB)*LD_W) = RHSCOMP(K,IPOSINRHSCOMP) ENDDO ENDDO !$OMP END PARALLEL DO #else !$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 #endif 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(40), 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 MUMPS_5.1.2/src/sfac_front_LU_type2.F0000664000175000017500000006061113164366263017507 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'smumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 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(40), 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), & 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)), NBPROCFILS(KEEP(28)), & 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 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 INTEGER PIVOT_OPTION, LAST_COL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER :: NOMP INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF NOMP=1 !$ NOMP=OMP_GET_MAX_THREADS() 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) IF (UUTEMP == 0.0E0 .AND. KEEP(201).NE.1) THEN ENDIF 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= .FALSE. NULLIFY(BEGS_BLR) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) 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 K263 = 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 IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 CNT_NODES = CNT_NODES + 1 CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL SYSTEM_CLOCK(TTOT1FR) ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 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 IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL SMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW, & 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, & IPIV & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. & (KEEP(485).EQ.0) & ) & ) 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 CALL SMUMPS_BUF_TEST() NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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, .FALSE., .TRUE., & .FALSE. ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF CALL SMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 2, 0) ENDIF IF (LR_ACTIVATED) THEN NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 101 ENDIF END_I=NB_BLR ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP(470), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H', 2) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (K263.NE.0) 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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR .LT. NASS) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, (PIVOT_OPTION.LT.2), .TRUE. & , (KEEP(377) .EQ. 1) & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF CALL SYSTEM_CLOCK(T1) IF (IEND_BLR.LT.NFRONT) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, .FALSE., .FALSE., & .FALSE. ) ENDIF CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_TRSM_TIME = LOC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR)) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & 0, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), BEGS_BLR(CURRENT_BLR+1), & NPARTSASS, BLR_L, CURRENT_BLR, 'V', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & NFRONT, KEEP(470), & END_I_IN=END_I & ) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) CALL DEALLOC_BLR_PANEL (BLR_L, NPARTSASS-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF (KEEP(201).EQ.1) 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 CALL STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, 0, INODE, & NELIM) CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_FLOP_FRONT_TYPE2(NFRONT, NASS, KEEP(50), & STEP_STATS(INODE), NELIM ) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 480 CONTINUE write(*,*) 'Allocation problem in BLR routine & SMUMPS_FAC_FRONT_LU_TYPE2: ', & 'not enough memory? memory requested = ' , IERROR 490 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE DEALLOCATE( IPIV ) RETURN END SUBROUTINE SMUMPS_FAC2_LU END MODULE SMUMPS_FAC2_LU_M MUMPS_5.1.2/src/zfac_front_type2_aux.F0000664000175000017500000006603413164366266020003 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NNEG, & 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) 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, NNEG INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR INTEGER, intent(inout) :: Inextpiv 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 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 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(201).EQ.1 .AND. KEEP(50).NE.1) 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 IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF ELSE IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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 APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG (IPIV) = abs(A(POSPV1)) 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 (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) 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 = max(abs(A(J1)),AMAX) 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)),RMAX_NOSLAVE) J1 = J1 + LDAFS8 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 KEEP(109) = KEEP(109)+1 PIVNUL_LIST(KEEP(109)) = -1 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 + LDAFS8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO DO J=1,NASS - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDAFS8 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 IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) 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 J1 = POSPV1 + LDAFS8 DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(J1)),RMAX_NOSLAVE) ENDIF J1 = J1 + LDAFS8 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 IF (KEEP(258).NE.0) THEN CALL ZMUMPS_UPDATEDETER(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(105) = KEEP(105)+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 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(201).EQ.1.AND.KEEP(50).NE.1) 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) 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 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(NASS - NPIV_NEW,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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, SEND_LR, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_TYPE IMPLICIT NONE INCLUDE 'zmumps_root.h' 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(40) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), & 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)), & NBPROCFILS(KEEP(28)), 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) :: SEND_LR 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 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 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, & SEND_LR, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/dana_aux.F0000664000175000017500000034510213164366263015421 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_ANA_F(N, NZ8, IRN, ICN, LIW8, IKEEP, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id) USE DMUMPS_STRUC_DEF USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: IRN(NZ8) INTEGER, INTENT(IN) :: ICNTL(40) INTEGER, INTENT(INOUT) :: ICN(NZ8) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(INOUT) :: INFO(40), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) TYPE (DMUMPS_STRUC) :: id INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE :: 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(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS #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 PIV(N) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL LOGICAL IDENT,SPLITROOT 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 ALLOCATE( IW (LIW8), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIW8,INFO(2)) GOTO 90 ENDIF ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( IPE(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 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 (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN WRITE (MP,99999) N, NZ8, LIW8, INFO(1) J8 = min(10_8,NZ8) IF (LDIAG.EQ.4) J8 = NZ8 IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) 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 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, ICN, IW(1), LIW8, & IPE, 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, SIZE_SCHUR, FRERE, FILS) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif 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, ICN, IW(1), LIW8, & IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265)) DEALLOCATE(IPQ8) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif INFO(8) = symmetry IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .LE. 1 ) 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( N, KEEP(50), NSLAVES, IORD, & symmetry, 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 IF(KEEP(95) .EQ. 2 .AND. IORD .EQ. 0) THEN IF (PROK) WRITE(MP,*) & 'WARNING: DMUMPS_ANA_F AMD not available with ', & ' compressed ordering -> move to QAMD' IORD = 6 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(id%CNTL(4) .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,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) 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, ICN, PIV, & NCMP, IW(1), LIW8, IPE, PTRAR(1,2), IPQ8, & IWL1, FILS, IWFR8, & IERROR, KEEP, KEEP8, ICNTL) 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)=id%COLSCA(J) ENDDO DO J=1, N id%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, ICN, IW(1), LIW8, IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265)) DEALLOCATE(IPQ8) INFO(8) = symmetry 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 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 (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, IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR, 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) 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 IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, N, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, N, 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 CALL DMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS) CALL DMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW(1), & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW(1), & 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 (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(1), IWL1, IKEEP, & IKEEP(1,2), NCMPA, INFO, LP, LPOK) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW(1), IWL1, IKEEP, & IKEEP(1,2), NCMPA, INFO, LP, LPOK, KEEP(10)) 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) THEN CALL DMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS) CALL DMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .GE. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IWL1(1) = -1 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4(NCMP, NBBUCK, LIW8, IPE, & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP, PARENT) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE, & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ, FRERE, PARENT) 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 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 TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_QAMD(TOTEL,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE, IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT) DEALLOCATE(WTEMP) ELSE CALL MUMPS_ANA_H(NCMP, LIW8, IPE, IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL DMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV,IKEEP(1,1),IKEEP(1,2)) 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 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF OPTIONS_METIS(1) = 0 #else OPT_METIS_SIZE = 40 OPT_METIS_SIZE = OPT_METIS_SIZE + 60 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF CALL METIS_SETDEFAULTOPTIONS(OPTIONS_METIS) OPTIONS_METIS(18) = 1 #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(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK, KEEP(10) ) 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(1), NUMFLAG, & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW(1), NUMFLAG, & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10)) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF #else ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW(1),FRERE(1), & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW(1),FRERE(1), & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10) ) 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 DEALLOCATE (OPTIONS_METIS) IF ( COMPRESS_SCHUR ) THEN CALL DMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP(1,1),IKEEP(1,2), & LISTVAR_SCHUR, SIZE_SCHUR, FILS) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL DMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV,IKEEP(1,1),IKEEP(1,2)) 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) & ) THEN DO K=1,N PTRAR(K,1) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (PTRAR(IKEEP(K,1),1).EQ.1) THEN GOTO 40 ELSE PTRAR(IKEEP(K,1),1) = 1 ENDIF ENDDO ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1) THEN IF ((KEEP(106)==1).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, ICN, IW(1), LIW8, & IPE, PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265)) DEALLOCATE(IPQ8) INFO(8) = symmetry ENDIF COMPRESS = 0 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. CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, LIW8, IPE, IWFR8, PTRAR(1,2), IW, & IWL1, WTEMP(N+1), & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, & PTRAR(1,3),IKEEP(1,1), LISTVAR_SCHUR, ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ELSE CALL DMUMPS_ANA_J(N, NZ8, IRN, ICN, IKEEP, IW(1), & LIW8, IPE, & 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, IW, LIW8, IWFR8, IKEEP, & IKEEP(1,2), 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, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else IF (allocated(IPE)) DEALLOCATE(IPE) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF CALL DMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, PTRAR, INFO(6), FILS, FRERE, & 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) 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(IKEEP(1,2), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP(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 .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) 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).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 CALL DMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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 CALL DMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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,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 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(IW)) DEALLOCATE(IW) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 9X, I8, I11, I12, I14) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I7, I12, I7, I12, I7)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) END SUBROUTINE DMUMPS_ANA_F 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) 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 #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,INT,NR1 #else INTEGER DADI LOGICAL AMALG_TO_father_OK #endif AMALG_COUNT = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 NODE(I) = 1 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE 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 NODE(IF) = NODE(IF)+1 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 #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 AMALG_TO_father_OK = .TRUE. 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 INT = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT) = -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, MAXFAC, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER NSTEPS,MAXNPIV INTEGER MAXFR, MAXELIM, K50, MAXFAC INTEGER K5,K6,PANEL_SIZE,K253 INTEGER NE(NSTEPS), ND(NSTEPS) INTEGER ITREE, NFR, NELIM INTEGER LKJIB LKJIB = max(K5,K6) MAXFR = 0 MAXFAC = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 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 MAXFAC = max(MAXFAC, (2*NFR - NELIM)*NELIM ) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE MAXFAC = max(MAXFAC, NFR * NELIM) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF 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_ANA_O( N, NZ, MTRANS, PERM, & id, ICNTL, INFO) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(N) INTEGER, INTENT(INOUT) :: MTRANS INTEGER, INTENT(IN) :: ICNTL(40) INTEGER, INTENT(INOUT) :: INFO(40) 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 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)) IF (PROK) WRITE(MPRINT,101) 101 FORMAT(/'****** Preprocessing of original matrix '/) K50 = id%KEEP(50) SCALINGLOC = .FALSE. IF(id%KEEP(52) .EQ. -2) THEN IF(.not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(id%KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF(K50 .NE. 2) THEN IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' ENDIF ENDIF IF(.not.associated(id%A)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF 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 MTRANSLOC = 5 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 => id%IS1(N+1:2*N) STR_KER => id%IS1(2*N+1:3*N) CALL DMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(2) 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 id%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 ) GOTO 410 ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (2*N+1)*id%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 ) GOTO 430 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 = id%IRN(K) J = id%JCN(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 = id%IRN(K) J = id%JCN(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(id%A)) THEN IF(abs(id%A(K)) .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 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 = id%IRN(K) J = id%JCN(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(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF K = 1_8 THEMIN = ZERO DO IF(THEMIN .NE. ZERO) EXIT THEMIN = abs(id%A(K)) K = K+1_8 ENDDO THEMAX = THEMIN DO K=1,NZ I = id%IRN(K) J = id%JCN(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(id%A(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(id%A(K)) .GT. THEMAX) THEN THEMAX = abs(id%A(K)) ELSE IF(abs(id%A(K)) .LT. THEMIN & .AND. abs(id%A(K)).GT. ZERO) THEN THEMIN = abs(id%A(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(id%A(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 CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N)) & - log(THEMIN) + ONE ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => id%IS1(3*N+1:4*N) IF(MTRANSLOC.NE.1) THEN CALL DMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM,IPQ8(1)) ELSE CALL DMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM) 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, 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 = id%JCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 id%JCN(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(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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( id%ROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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 id%KEEP(52) = -2 id%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) id%ROWSCA(J) = exp(S2(RSPOS+J8)) IF(id%ROWSCA(J) .EQ. ZERO) THEN id%ROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN id%COLSCA(J)= exp(S2(CSPOS+J8)) IF(id%COLSCA(J) .EQ. ZERO) THEN id%COLSCA(J) = ONE ENDIF ELSE id%COLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(id%COLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN id%COLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(id%COLSCA)) DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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( id%ROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN id%INFO(1)=-5 id%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 id%KEEP(52) = -2 id%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 id%ROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(id%ROWSCA(J) .EQ. ZERO) THEN id%ROWSCA(J) = ONE ENDIF id%COLSCA(J)= id%ROWSCA(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) id%ROWSCA(I) = ONE / COLNORM id%COLSCA(I) = id%ROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. id%KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. id%KEEP(95) .EQ. 0) THEN MTRANS = 0 id%KEEP(95) = 1 GOTO 390 ELSE IF(id%KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN id%KEEP(95) = 3 ELSE id%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 => id%IS1(2*N+1:3*N) FLAG => id%IS1(3*N+1:4*N) PIV_OUT => id%IS1(4*N+1:5*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, & 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( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 & ) THEN IDENT = .TRUE. id%KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF id%KEEP(93) = INFO_SYM_MWM(4) id%KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN id%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 SUBROUTINE DMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL ) IMPLICIT NONE INTEGER COMM, MYID, KEEP(500), INFO(40), ICNTL(40), INFOG(40) 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), 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) Storage of factors (REAL, estimated) =',I16/ & ' -- (4) Storage of factors (INT , 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/ & 'Percentage of memory relaxation (effective) =',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, 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 ) 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 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)), & 1_8) IF (KEEP(53).NE.0) THEN MAX_CUT = NFRONT K79 = 121_8*121_8 ELSE K79 = min(2000_8*2000_8,K79) 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 ) 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 ) 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 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_SON, NPIV_FATH 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 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 DO WHILE( IN > 0 ) IN = FILS( IN ) NPIV = NPIV + 1 END DO 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)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375)) 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 NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 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 IN_SON = INODE DO I = 1, NPIV_SON - 1 IN_SON = FILS( IN_SON ) END DO 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 ) 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 ) 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) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(40) 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) 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 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) 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 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE 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 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 ((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 ELSE symmetry = 100 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 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_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(40) 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).GE.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, 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(INOUT) :: INFO(40) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN 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) IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO 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 DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE DMUMPS_SORT_PERM SUBROUTINE DMUMPS_ANA_N_PAR( id, PTRAR ) USE DMUMPS_STRUC_DEF IMPLICIT NONE include 'mpif.h' TYPE(DMUMPS_STRUC), INTENT(IN), TARGET :: id INTEGER(8), INTENT(OUT), TARGET :: PTRAR(id%N,2) INTEGER :: IERR 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(1:id%N,2) allocate(IWORK2(id%N)) IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => PTRAR(1:id%N,1) IWORK2 => PTRAR(1:id%N,2) 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,1), id%N, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), id%N, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR, 2*id%N, MPI_INTEGER8, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE DMUMPS_ANA_N_PAR SUBROUTINE DMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(40),INFOG(40),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) DOUBLE PRECISION PEAK CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & ) 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.1.2/src/zfac_mem_stack_aux.F0000664000175000017500000001543013164366265017464 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, COMPRESSCB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: COMPRESSCB 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. COMPRESSCB ) 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. COMPRESSCB) 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, COMPRESSCB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: COMPRESSCB 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 > 300) DO I = 1, NBROW_STACK IF (COMPRESSCB) 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. COMPRESSCB) 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.1.2/src/mumps_save_restore_C.h0000664000175000017500000000120213164366240020050 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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_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.1.2/src/mumps_sol_es.F0000664000175000017500000006245413164366241016350 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE MUMPS_SOL_ES PRIVATE PUBLIC:: PRUNED_SIZE_LOADED PUBLIC:: MUMPS_CHAIN_PRUN_NODES PUBLIC:: MUMPS_CHAIN_PRUN_NODES_STATS PUBLIC:: MUMPS_INITIALIZE_RHS_BOUNDS PUBLIC:: MUMPS_PROPAGATE_RHS_BOUNDS PUBLIC:: MUMPS_TREE_PRUN_NODES PUBLIC:: MUMPS_TREE_PRUN_NODES_STATS PUBLIC:: MUMPS_SOL_ES_INIT INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK INTEGER(8) :: PRUNED_SIZE_LOADED CONTAINS SUBROUTINE MUMPS_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 MUMPS_SOL_ES_INIT SUBROUTINE MUMPS_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 MUMPS_TREE_PRUN_NODES SUBROUTINE MUMPS_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 MUMPS_CHAIN_PRUN_NODES SUBROUTINE MUMPS_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 MUMPS_INITIALIZE_RHS_BOUNDS SUBROUTINE MUMPS_PROPAGATE_RHS_BOUNDS( & pruned_leaves, nb_pruned_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, NSTEPS, & MYID, COMM, & 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 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, 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 MUMPS_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 MUMPS_PROPAGATE_RHS_BOUNDS INTEGER(8) FUNCTION MUMPS_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 MUMPS_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 MUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (NROW-NPIV)*NPIV ELSE MUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV+1_8)/2_8 + (LIELL-NPIV)*NPIV ENDIF ELSE MUMPS_LOCAL_FACTOR_SIZE = & -NCB*NELIM END IF RETURN END FUNCTION MUMPS_LOCAL_FACTOR_SIZE SUBROUTINE MUMPS_TREE_PRUN_NODES_STATS(MYID, N, KEEP28, KEEP201, & KEEP8_31, & 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) :: KEEP8_31 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 MUMPS_TREE_PRUN_NODES_STATS SUBROUTINE MUMPS_CHAIN_PRUN_NODES_STATS & (MYID, N, KEEP28, KEEP201, KEEP8_31, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, N INTEGER(8), intent(in) :: KEEP8_31 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 (KEEP8_31 .NE. 0_8) THEN PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF ENDIF RETURN END SUBROUTINE MUMPS_CHAIN_PRUN_NODES_STATS END MODULE MUMPS_SOL_ES SUBROUTINE MUMPS_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 ", & " MUMPS_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) & WRITE(LP,*) " ERROR -2 : ", & " ALLOCATE IN MUMPS_PERMUTE_RHS_GS OF SIZE :", & NRHS 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 ", & " MUMPS_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 ", & " MUMPS_PERMUTE_RHS_GS ", maxval(ROW_REFINDEX) IERR = -4 GOTO 500 ENDIF 490 CONTINUE 500 CONTINUE IF (allocated(ROW_REFINDEX)) DEALLOCATE(ROW_REFINDEX) END SUBROUTINE MUMPS_PERMUTE_RHS_GS SUBROUTINE MUMPS_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 MUMPS_PERMUTE_RHS_AM1 SUBROUTINE MUMPS_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, & 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, & 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 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 MUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF MYTYPENODE= (PROCNODE-1+2*SLAVEF)/SLAVEF-1 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 MUMPS_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 MUMPS_INTERLEAVE_RHS_AM1 MUMPS_5.1.2/src/sana_dist_m.F0000664000175000017500000007511413164366262016124 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, & NA, LNA, NE, DAD, ND, PROCNODE, SLAVEF, & NRLADU, NIRADU, NIRNEC, NRLNEC, & NRLNEC_ACTIVE, & NIRADU_OOC, NIRNEC_OOC, & MAXFR, OPSA, & KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND, SBUF_REC, 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 & ) IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER MYID, N, LNA, IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE 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), NA(LNA), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) 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, SBUF_REC 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, IPOOL, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR LOGICAL OUTER_SENDS_FR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER SBUFR, SBUFS INTEGER BLOCKING_RHS INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, NBROOT, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB, & LKJIBT, NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL COMPRESSCB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART 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 INTEGER MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_MAX_SURFCB_NBROWS, MUMPS_BLOC2_GET_NSLAVESMAX 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 COMPRESSCB=( 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), IPOOL(NSTEPS), & LSTKI(NSTEPS) , stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 4*NSTEPS RETURN endif LKJIB = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0) IF ( OUTER_SENDS_FR ) THEN LKJIB = max(LKJIB, KEEP(420)) ENDIF IF ( KEEP(486).NE.0 ) THEN LKJIB = max(LKJIB,KEEP(488)) ENDIF TNSTK = NE LEAF = NA(1)+1 IPOOL(1:LEAF-1) = NA(3:3+LEAF-2) NBROOT = NA(2) #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 = 0_8 ISTKI = 0 ISTKI_OOC = 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 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 NRLNEC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 ITOP = 0 MAXTEMPCB = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS = 1 SBUFR_CB = 1_8 SBUFR = 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 IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),SLAVEF) & .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 WRITE(MYID+6,*) ' ERROR 1 in SMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() 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)),SLAVEF) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),SLAVEF) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & SLAVEF) 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. COMPRESSCB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 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 & ) 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 NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & int(LOCAL_M,8)*int(LOCAL_N,8)) NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) 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)), SLAVEF)) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) 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 = max(SBUFS, NFR*LKJIB+LKJIB+4) ELSE SBUFS = max(SBUFS, NELIM*LKJIB+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR = max(SBUFR, NFR*LKJIB+LKJIB+4) else SBUFR = max( SBUFR, NELIM*LKJIB+NELIM+6 ) IF (KEEP(50).EQ.1) THEN LKJIBT = LKJIB ELSE LKJIBT = min( NELIM, LKJIB * 2 ) ENDIF SBUFS = max(SBUFS, & LKJIBT*NBROWMAX+6) SBUFR = max( SBUFR, NBROWMAX*LKJIBT+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 SIZECBI = 2* NCB + 6 + 3 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 MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECBI = NCB + 5 + 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) NRLADU = NRLADU + NRLADU_CURRENT ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) NRLADU = NRLADU + NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECBI = 4 + NBROWMAX + NCB 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 (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 (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 = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) ENDIF 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 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)),SLAVEF) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),SLAVEF) 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 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)), & SLAVEF) .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 NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF 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)),SLAVEF) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)),SLAVEF).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) ELSE NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) ENDIF 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) 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) 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. COMPRESSCB)) 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 * NFR + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.COMPRESSCB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN SIZECBI = 2+ XSIZE_IC ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) 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)) SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) SIZECBI = 0 SIZECB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE 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 SIZECBI = NCB + 5 + SLAVEF - 1 + XSIZE_IC SIZECB = 0_8 ELSE IF (UPDATE) THEN SIZECBI = NFR + 6 + SLAVEF - 1 + XSIZE_IC IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 SIZECBI = 0 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (COMPRESSCB) 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 = NCB + 5 + SLAVEF - 1 + XSIZE_IC ELSE SIZECB = SIZECB_SLAVE SIZECBI = 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) ) 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 BLOCKING_RHS = KEEP(84) IF (KEEP(84).EQ.0) BLOCKING_RHS=1 NRLNEC = max(NRLNEC, & NRLADU+int(4*KEEP(127)*abs(BLOCKING_RHS),8)) IF (BLOCKING_RHS .LT. 0) THEN BLOCKING_RHS = - 2 * BLOCKING_RHS ENDIF NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(4*KEEP(127)*BLOCKING_RHS,8)) SBUF_RECOLD = max(int(SBUFR,8),SBUFR_CB) SBUF_RECOLD = max(SBUF_RECOLD, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC = max(SBUFR, int(min(100000_8,SBUFR_CB))) SBUF_REC = SBUF_REC + 17 SBUF_REC = SBUF_REC + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND = max(SBUFS, int(min(100000_8,SBUFR_CB))) SBUF_SEND = SBUF_SEND + 17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC = SBUF_REC+KEEP(108)+1 SBUF_SEND = SBUF_SEND+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC = 1 SBUF_SEND= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, IPOOL, & LSTKI ) OPS_SUBTREE = real(OPS_SBTR_LOC) OPSA = real(OPSA_LOC) KEEP(66) = int(OPSA_LOC/1000000.d0) RETURN END SUBROUTINE SMUMPS_ANA_DISTM MUMPS_5.1.2/src/cfac_process_maprow.F0000664000175000017500000014246513164366264017670 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif IMPLICIT NONE INCLUDE 'cmumps_root.h' #if ! defined(NO_FDM_MAPROW) #endif TYPE (CMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) 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 ) 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 COMPRESSCB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE, TYPESPLIT INTEGER KEEP253_LOC #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 IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE_PERE)), & SLAVEF) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in CMUMPS_MAPLIG' 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)), & SLAVEF ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) write(LP,*) MYID, & ' : PB allocation NBROW in CMUMPS_MAPLIG' 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)), & SLAVEF) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 7 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO #endif ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 9 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO_SYM #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM 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( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) 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 COMPRESSCB=(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 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(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & A(PTRAST(STEP(ISON))), I, PDEST, PDEST_MASTER, & COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, COMPRESSCB, & KEEP253_LOC ) 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF ITYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), SLAVEF) 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, MYID, COMM, KEEP,KEEP8, DKEEP,ITYPE & ) 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 &) 600 CONTINUE DEALLOCATE(PERM) 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 40 ), 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 INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ) 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 NBPROCFILS( KEEP(28) ) 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 ) 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) :: APOS, POSROW, ASIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL COMPRESSCB INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM 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)), & SLAVEF ) 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(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ': PB allocation PERM in CMUMPS_MAPLIG_FILS_NIV1' 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( 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)) 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 COMPRESSCB=(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 DECR=1 NBPROCFILS(STEP(INODE_PERE)) = & NBPROCFILS(STEP(INODE_PERE)) - DECR NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR #if ! defined(NO_XXNBPR) IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE_PERE)), & IW(PTLUST(STEP(INODE_PERE))+XXNBPR)) IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXNBPR)) #endif DO II = 1,NROWS_TO_STACK IROW_SON=PERM(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 (COMPRESSCB) THEN IF (NELIM.EQ.0) THEN POSROW = PAMASTER(STEP(ISON)) + & int(IROW_SON,8)*int(IROW_SON-1,8)/2_8 ELSE POSROW = PAMASTER(STEP(ISON)) + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ENDIF ELSE POSROW = PAMASTER(STEP(ISON)) + & 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 CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF) ENDDO IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (COMPRESSCB) THEN POSROW = PAMASTER(STEP(ISON)) & + 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 = PAMASTER(STEP(ISON)) + & 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).GT. 0 ) THEN CALL CMUMPS_COMPUTE_MAXPERCOL( & A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253), & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB, & NELIM+NBROW(1)) ELSE CALL CMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF CALL CMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXNBPR)) IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 #endif & ) 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 ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE_PERE)), & IW(PTLUST(STEP(INODE_PERE))+XXNBPR)) IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 #endif & ) THEN CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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)) APOS = PAMASTER(STEP(ISON)) 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 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(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & A(APOS), I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & COMPRESSCB, KEEP(253)) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 CMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) 600 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(MAP) DEALLOCATE(PERM) DEALLOCATE(SLAVES_PERE) RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 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, NBPROCFILS, & 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL & ) USE CMUMPS_BUF, ONLY: CMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE CMUMPS_LOAD, ONLY : CMUMPS_LOAD_POOL_UPD_NEW_POOL INTEGER ICNTL(40) 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(inout) :: NBPROCFILS( KEEP(28) ) 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 INTEGER, intent(in) :: FILS(N) 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 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 LOGICAL :: COMPRESSCB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) #if ! defined(NO_XXNBPR) INTEGER :: INBPROCFILS_SON #endif 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 NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - DECR #if ! defined(NO_XXNBPR) IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR #endif IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR #if ! defined(NO_XXNBPR) IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR #endif 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 COMPRESSCB = (IW(ISTCHK+XXS).EQ.S_CB1COMP) CALL MUMPS_GETI8(SIZFR, IW(ISTCHK+XXR)) IF (IW(ISTCHK+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 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 ) 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 ) ENDIF ENDIF DO II = 1,NROWS_TO_STACK 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 ( COMPRESSCB ) THEN IF (NBCOLS - NROW .EQ. 0 ) THEN ITMP = IROW_SON POSROW = PTRAST(STEP(ISON))+ & int(ITMP,8) * int(ITMP-1,8) / 2_8 ELSE ITMP = IROW_SON + NBCOLS - NROW POSROW = PTRAST(STEP(ISON)) & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ENDIF ELSE POSROW = PTRAST(STEP(ISON)) + 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 CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.COMPRESSCB).AND.(IS_ofType5or6) ) THEN CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) ENDIF ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV 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) & .OR. & ( (KEEP(50).NE.0).and. (.NOT.COMPRESSCB) ) & ) & ) THEN CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - & NROWS_TO_STACK #if ! defined(NO_XXNBPR) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK #endif EXIT ELSE CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - 1 #if ! defined(NO_XXNBPR) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 #endif ENDIF ENDIF ENDDO IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (COMPRESSCB) THEN WRITE(*,*) "Error 1 in PARPIV/CMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = PTRAST(STEP(ISON))+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 .NE. 0 ) THEN CALL CMUMPS_COMPUTE_MAXPERCOL( & A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, LMAP_LOC-NBROW(1)+1-KEEP253_LOC, & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB,ITMP) ELSE CALL CMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF CALL CMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB #if ! defined(NO_XXNBPR) 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 #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL( NBPROCFILS(STEP(ISON)), & IW(INBPROCFILS_SON) ) IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN #endif 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 CMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, & ISTCHK_LOC, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL( NBPROCFILS(STEP(IFATH)), & IW(PTLUST(STEP(IFATH))+XXNBPR) ) IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(IFATH)) .EQ. 0 #endif & ) THEN CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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.1.2/src/sfac_process_band.F0000664000175000017500000002352713164366262017302 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & TNBPROCFILS, N, IW, LIW, A, LA, & 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 #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(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & TNBPROCFILS( 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 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 ) IBUFR = 10 #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, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, 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+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 TNBPROCFILS(STEP( INODE )) = NBPROCFILS # if ! defined(NO_XXNBPR) IW(IWPOSCB+1+XXNBPR)=NBPROCFILS # endif IW(IWPOSCB+1+XXLR)=LRSTATUS 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'smumps_root.h' INTEGER, INTENT(IN) :: INODE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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)), & SLAVEF ) # 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, & NBPROCFILS, N, IW, LIW, A, LA, & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/mumps_c.c0000664000175000017500000004604313164366240015336 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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_commn.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 *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 *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_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 *nz_rhs, MUMPS_INT *lsol_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 *ooc_tmpdirlen, MUMPS_INT *ooc_prefixlen, MUMPS_INT *write_problemlen ); /* * 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; } #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 *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; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_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 colsca_avail, rowsca_avail; MUMPS_INT irhs_ptr_avail, rhs_sparse_avail, sol_loc_avail; MUMPS_INT irhs_sparse_avail, isol_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]; /* 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 write_problemlen; 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->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->colsca_from_mumps=0; mumps_par->rhs_sparse=0; mumps_par->irhs_sparse=0; mumps_par->sol_loc=0; mumps_par->irhs_ptr=0; mumps_par->isol_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"); 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->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->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); /* 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; } /* * 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(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 { /* FIXME: changing rowsca in C after an earlier call where rowsca was computed by mumps is not possible. */ 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 { /* FIXME: changing colsca in C after an earlier call where colsca was computed by mumps is not possible */ colsca = rdummyp; colsca_avail = no; } EXTRACT_POINTERS(rhs_sparse,cdummyp); EXTRACT_POINTERS(sol_loc,cdummyp); EXTRACT_POINTERS(irhs_sparse,idummyp); EXTRACT_POINTERS(isol_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]; } /* Call F77 interface */ MUMPS_F77(&(mumps_par->job), &(mumps_par->sym), &(mumps_par->par), &(mumps_par->comm_fortran), &(mumps_par->n), 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, 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, irhs_sparse, &irhs_sparse_avail, irhs_ptr, &irhs_ptr_avail, isol_loc, &isol_loc_avail, &(mumps_par->nz_rhs), &(mumps_par->lsol_loc) , &(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 , &ooc_tmpdirlen , &ooc_prefixlen , &write_problemlen ); /* * 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.1.2/src/zfac_type3_symmetrize.F0000664000175000017500000001362113164366265020200 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/lr_common.F0000664000175000017500000000520113164366241015613 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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), & NE_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: FILS(N), FRERE_STEPS(NSTEPS), & DAD_STEPS(NSTEPS), STEP(N), PVS(NSTEPS), NA(LNA), 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.1.2/src/sfac_front_LDLT_type1.F0000664000175000017500000004504213164366263017726 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NNEG, NPVW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS & , LRGROUPS & ) 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 !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR, NNEG, NPVW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL UU, SEUIL REAL A( LA ) INTEGER, TARGET :: IW( LIW ) 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 REAL MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL LOGICAL LASTBL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL,ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok INTEGER :: OMP_NUM REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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 IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU SEUIL_LOC = SEUIL ENDIF PIVOT_OPTION = KEEP(468) 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(BEGS_BLR) 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 (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 IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTBL = .FALSE. IF (KEEP(201).EQ.1) THEN IDUMMY = -8765 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 PIVOT_OPTION = 3 CNT_NODES = CNT_NODES + 1 CALL INIT_STATS_FRONT(NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL INIT_STATS_FRONT(-NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1FR) ENDIF IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL SMUMPS_FAC_I_LDLT(NFRONT,NASS,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEG, 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IF (IFLAG.LT.0) GOTO 500 IF(KEEP(109).GT. 0) THEN IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE & +IW(IOLDPS+5+XSIZE) PIVNUL_LIST(KEEP(109)) = IW(IWPOSP2) ENDIF ENDIF IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN NPVW = NPVW + PIVSIZ IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) 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), & KEEP(253), & PIVOT_OPTION, IEND_BLR & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 ( KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. (.NOT. COMPRESS_PANEL) .OR. & (KEEP(485).EQ.0) & ) & ) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,IEND_BLR,INODE,A,LA, & LDA, POSELT, & KEEP,KEEP8, & PIVOT_OPTION, .FALSE.) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,NASS,INODE,A,LA, & LDA, POSELT, & KEEP,KEEP8, PIVOT_OPTION, .TRUE.) ELSE CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 1, 1) NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(8), KEEP(477) & ) IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V',1) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR,'V', & NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & dble(T2-T1)/dble(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF IF (KEEP(201).EQ.1.AND.(PIVOT_OPTION.GE.3)) 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 IF (COMPRESS_CB) THEN CALL SMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, NPARTSCB+NPARTSASS, & BEGS_BLR, NPARTSCB+NPARTSASS, NPARTSASS, & DKEEP(8), NASS, NFRONT-NASS, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, STEP_STATS(INODE), 1, & .FALSE., 0, KEEP(484)) END IF CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NFRONT-NASS, & KEEP(50), INODE, NASS-NPIV ) CALL STATS_COMPUTE_FLOP_FRONT_TYPE1(NFRONT, NASS, NPIV, & KEEP(50), INODE) LOC_LR_MODULE_TIME = dble(TTOT2-TTOT1)/dble(COUNT_RATETOT) 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)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (COMPRESS_PANEL) THEN IF ( PIVOT_OPTION.NE.3 & ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_FACTO_NIV1" CALL MUMPS_ABORT() ENDIF ELSE 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) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 490 CONTINUE write(*,*) 'Allocation problem in BLR routine & SMUMPS_FAC_FRONT_LDLT_TYPE1: ', & 'not enough memory? memory requested = ' , IERROR 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC1_LDLT END MODULE SMUMPS_FAC1_LDLT_M MUMPS_5.1.2/src/sarrowheads.F0000664000175000017500000006731313164366262016167 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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( 40 ) 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 INTEGER(8) :: IPTRI, IPTRR 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), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), SLAVEF ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), SLAVEF ) 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 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), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), SLAVEF ) 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. 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 ) IMPLICIT NONE INCLUDE 'smumps_root.h' 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,INEW,JNEW,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 TYPENODE_TMP, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: I1, IA, IIW, IS1, IS, IAS, ISHIFT, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, POINTER, DIMENSION(:,:) :: IW4 ARROW_ROOT = 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 ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER(int(I-1,8)*int(root%SCHUR_LLD,8)+1_8: & int(I-1,8)*int(root%SCHUR_LLD,8)+int(root%SCHUR_MLOC,8))= & ZERO ENDDO ENDIF 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 DO 120 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 GOTO 120 END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF 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 ENDIF ENDIF IARR = abs( ISEND ) ISTEP = abs( STEP(IARR) ) TYPENODE_TMP = MUMPS_TYPENODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE = MUMPS_PROCNODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & SLAVEF ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF (TYPENODE_TMP.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) 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 IF ( TYPENODE_TMP .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPENODE_TMP .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 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 )/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 END IF 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 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPENODE_TMP .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 IIW = IS1 + ISHIFT + 2_8 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = 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 ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 .OR. .TRUE.) & .AND. IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF (MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) == 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 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)) END IF 120 CONTINUE 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 & ) IMPLICIT NONE INCLUDE 'smumps_root.h' 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 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 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) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I=1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC)=ZERO ENDDO ENDIF 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)))), & SLAVEF ) .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 .OR. .TRUE.) & .AND. IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) 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 MUMPS_5.1.2/src/zfac_determinant.F0000664000175000017500000001444013164366265017156 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.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 MUMPS_5.1.2/src/cfac_process_end_facto_slave.F0000664000175000017500000002366413164366264021476 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ) 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 #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) CALL CMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF), IFLAG, KEEP8, .TRUE.) IW(IOLDPS+XXS)=S_ALL 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, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG 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(70) = KEEP8(70) + MEM_GAIN KEEP8(71) = KEEP8(71) + MEM_GAIN CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) 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 IW(IOLDPS+XXS)=S_NOLCBCONTIG 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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, 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(70) = KEEP8(70) + MEM_GAIN KEEP8(71) = KEEP8(71) + 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/zana_aux_ELT.F0000664000175000017500000010673013164366265016157 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) 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(40) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(40), 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) 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, 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, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS 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 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF OPTIONS_METIS(1) = 0 #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 OPT_METIS_SIZE = OPT_METIS_SIZE + 60 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE RETURN ENDIF CALL METIS_SETDEFAULTOPTIONS(OPTIONS_METIS) OPTIONS_METIS(18) = 1 #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(1), #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG(1), #endif & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2(1), #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG(1), #endif & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), & LP, LPOK, KEEP(10) ) 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) #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), & KEEP(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 CALL ZMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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 CALL ZMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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, I8, 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(40) 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( 40 ) 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 TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), SLAVEF ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .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 ) IMPLICIT NONE INTEGER N, NELT, SLAVEF INTEGER PROCNODE( N ), ELTPROC( NELT ) INTEGER ELT, I, ITYPE, MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),SLAVEF) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),SLAVEF) ELSE IF (ITYPE.EQ.2) 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.1.2/src/cfac_distrib_distentry.F0000664000175000017500000006417013164366264020366 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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))), & SLAVEF ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & SLAVEF ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & SLAVEF ) 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 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( 40 ), ICNTL(40) 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, INEW, JNEW INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 LOGICAL T4_MASTER_CONCERNED COMPLEX VAL INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE 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 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 IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC) = ZERO ENDDO ENDIF 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) DO K8 = 1_8, NZ_loc8 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, & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF 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) ) CYCLE 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 (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 ENDIF ENDIF IARR = abs( ISEND ) ISTEP = abs(STEP(IARR)) TYPE_NODE = MUMPS_TYPENODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE= MUMPS_PROCNODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & SLAVEF ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF (TYPE_NODE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF ELSE 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 END IF if (DEST .eq. -1) 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 end if IF ( DEST.EQ.-1) THEN DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDDO 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, ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDIF ELSE 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, ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDIF ENDIF END DO DEST = -2 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, ARROW_ROOT, 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, & ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, & KEEP,KEEP8 ) IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER ARROW_ROOT, 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. -2 ) 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. -2 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -2 .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, & ARROW_ROOT, 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. -2 ) 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, & ARROW_ROOT, 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, ARROW_ROOT, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER NBRECORDS, N, ARROW_ROOT, 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, IROW_GRID, JCOL_GRID, & ILOCROOT, JLOCROOT INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT, IARR, JARR INTEGER TAILLE COMPLEX VAL 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 )))), & SLAVEF ) IF ( NODE_TYPE .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .NE. root%MYROW .OR. & JCOL_GRID .NE. root%MYCOL ) THEN WRITE(*,*) MYID,':INTERNAL Error: recvd root arrowhead ' WRITE(*,*) MYID,':not belonging to me. IARR,JARR=',IARR,JARR WRITE(*,*) MYID,':IROW_GRID,JCOL_GRID=',IROW_GRID,JCOL_GRID WRITE(*,*) MYID,':MYROW, MYCOL=', root%MYROW, root%MYCOL WRITE(*,*) MYID,':IPOSROOT,JPOSROOT=', IPOSROOT, JPOSROOT CALL MUMPS_ABORT() 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 IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) & .AND. & IW4(IARR,1) .EQ. 0 .AND. & IPROC .EQ. MYID & .AND. STEP(IARR) > 0 ) 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 ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE CMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.1.2/src/zfac_asm_master_m.F0000664000175000017500000017233213164366266017321 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,NBPROCFILS, 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 MUMPS_BUILD_SORT_INDEX_M USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N,LIW,NSTEPS INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 COMPLEX(kind=8), TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, NBFIN, SLAVEF, MYID 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 NBPROCFILS(KEEP(28)), NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) 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 ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE 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 INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8 INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC INTEGER(8) :: SIZFR8 INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM, & IBROT,IORG 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 INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE, OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER, POINTER :: SON_IWPOS INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 COMPRESSCB =.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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)), & SLAVEF) 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 LREQ_OOC = 0 IF (KEEP(201).EQ.1) 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) 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)),SLAVEF) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF END IF END IF END IF END IF NIV1 = .TRUE. CALL MUMPS_BUILD_SORT_INDEX( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, 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)), & SLAVEF))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) 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 NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF IF (LRLU .LT. LAELL_REQ8) THEN IF (LRLUS .LT. LAELL_REQ8) THEN IF (LPOK) THEN WRITE(LP, * ) ' NOT ENOUGH MEMORY during ASSEMBLY ', & ' MEMORY REQUESTED = ', LAELL_REQ8, & ' AVAILABLE =', LRLUS ENDIF GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 4 after compress ' WRITE(LP, * ) 'IN ZMUMPS_FAC_ASM_NIV1' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 + SIZE_ISON_TOP8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 + SIZE_ISON_TOP8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) #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=3000 !$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 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 TOPDIAG = max(KEEP(7), KEEP(8))-1 !$ 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 ) TOPDIAG = max(KEEP(7), KEEP(8), KEEP(57), KEEP(58))-1 !$ 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)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 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_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) 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 COMPRESSCB = & ( SON_IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( SON_IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF 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) THEN K2 = K1 + LSTK - 1 IF (COMPRESSCB) THEN SIZFR8 = (int(LSTK,8)*int(LSTK+1,8))/2_8 ELSE SIZFR8 = int(LSTK,8)*int(LSTK,8) ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * int(LSTK,8) ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) 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.300) !$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) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR8 ELSE LCB = int(LDA_SON,8) * int(K2-K1+1,8) ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL ZMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB) ELSE IF (LCB .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB & ) 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(SSARBR, MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 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 280 CONTINUE INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL_REQ8 - LRLUS, INFO(2)) IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL 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 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, & NBPROCFILS, 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(40) 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) 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 NBPROCFILS(KEEP(28)), & 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 INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER,I INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 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 !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. COMPRESSCB = .FALSE. ETATASS = 0 IN = INODE NBPROCFILS(STEP(IN)) = 0 NSTEPS = NSTEPS + 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)), & SLAVEF) .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 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)), & SLAVEF) 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)), & SLAVEF) 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) 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) 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) 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) GOTO 275 ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, 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) 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) #if defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) IF ( KEEP(73) .EQ. 0 ) THEN #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 defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) ENDIF #endif #endif 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 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 3 after compress ' WRITE(LP, * ) 'IN ZMUMPS_FAC_ASM_NIV2' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 = max(int(KEEP(361)/2,8), !$ & (LAELL8+NOMP-1) / NOMP ) !$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 !$ 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 COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) 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) + 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) + A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (NSLSON.EQ.0) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF IF (LCB .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & COMPRESSCB & ) 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, & 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), & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 280 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) 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.1.2/src/omp_tps_common_m.F0000664000175000017500000000067713164366241017207 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE MUMPS_TPS_M_RETURN() RETURN END SUBROUTINE MUMPS_TPS_M_RETURN MUMPS_5.1.2/src/dsol_fwd.F0000664000175000017500000001225113164366263015436 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, & NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, 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_OOC IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB, LNA INTEGER SLAVEF, MYLEAF, COMM, MYID INTEGER INFO( 40 ), 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 NA( LNA ), NE_STEPS( KEEP(28) ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK_S(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 #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION, intent(inout) :: RHSCOMP(NRHS,LRHSCOMP) #else DOUBLE PRECISION, intent(inout) :: RHSCOMP(LRHSCOMP,NRHS) #endif LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGSOU, DUMMY(1) LOGICAL FLAG INTEGER NBFIN, MYROOT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE INTEGER I INTEGER III, NBROOT,LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 DO I = 1, KEEP(28) NSTK_S(I) = NE_STEPS(I) ENDDO PTRICB = 0 CALL MUMPS_INIT_POOL_DIST(N, LEAF, MYID, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID, & SLAVEF, NA, LNA, KEEP, STEP, & PROCNODE_STEPS) NBFIN = SLAVEF IF ( MYROOT .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 MYLEAF = LEAF - 1 III = 1 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, III, 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 .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_SOLVE_NODE( INODE, BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, III, 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, & MYROOT, INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 .OR. 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.1.2/src/dana_aux_ELT.F0000664000175000017500000010673013164366263016127 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) 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(40) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(40), 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) 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, 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, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS 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 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE GOTO 90 ENDIF OPTIONS_METIS(1) = 0 #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 OPT_METIS_SIZE = OPT_METIS_SIZE + 60 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = OPT_METIS_SIZE RETURN ENDIF CALL METIS_SETDEFAULTOPTIONS(OPTIONS_METIS) OPTIONS_METIS(18) = 1 #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(1), #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG(1), #endif & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2(1), #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG(1), #endif & OPTIONS_METIS, OPT_METIS_SIZE, & IKEEP(1,2), IKEEP(1,1), INFO(1), & LP, LPOK, KEEP(10) ) 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) #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), & KEEP(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 CALL DMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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 CALL DMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,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, I8, 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(40) 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( 40 ) 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 TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), SLAVEF ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .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 ) IMPLICIT NONE INTEGER N, NELT, SLAVEF INTEGER PROCNODE( N ), ELTPROC( NELT ) INTEGER ELT, I, ITYPE, MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),SLAVEF) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),SLAVEF) ELSE IF (ITYPE.EQ.2) 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.1.2/src/zfac_lr.F0000664000175000017500000010674513164366266015274 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE ZMUMPS_FAC_LR USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_ANA_LR 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, & COMPRESS_MID_PRODUCT, TOLEPS, 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 INTEGER, intent(out) :: IFLAG, IERROR COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR-CURRENT_BLR) COMPLEX(kind=8), INTENT(INOUT), TARGET :: BLOCK(:,:) INTEGER, intent(in) :: IW2(*) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK COMPLEX(kind=8), POINTER, DIMENSION(:) :: BLOCK_PTR 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 BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,1) #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, BLOCK_PTR, !$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 = OMP_GET_THREAD_NUM() BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1) #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL ZMUMPS_LRGEMM3('N', 'T', MONE, & BLR_L(J),BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, NFRONT, & IW2, & BLOCK_PTR, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_L(J), BLR_L(I), 'N', & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ & , (I.EQ.J) & ) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE ZMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, POSBLOCFACTO, 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, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, POSBLOCFACTO COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(out) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), & 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, POINTER, 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) :: COMPRESS_MID_PRODUCT, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ 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 = POSBLOCFACTO #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, 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 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_LRGEMM3('N', 'T', MONE, & BLR_LM(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, 2, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, LD_BLOCFACTO, & IW2, & BLOCK, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LM(J), BLR_LS(I), & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, & .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, 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 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_LRGEMM3('N', 'T', MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, 2, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, LD_BLOCFACTO, & IW2, & BLOCK, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LS(J), BLR_LS(I), & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, & (I.EQ.J)) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE ZMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT SUBROUTINE ZMUMPS_BLR_UPDATE_NELIM_VAR( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, CURRENT_BLR, & NELIM, SYM, NIV, FIRST_BLOCK LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(out) :: IFLAG, IERROR INTEGER, intent(in) :: ISHIFT COMPLEX(kind=8), TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL, IS INTEGER :: allocok 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 IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if defined(BLR_MT) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = FIRST_BLOCK-CURRENT_BLR, 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 write(*,*) 'Allocation problem in BLR routine & ZMUMPS_BLR_UPDATE_NELIM_VAR: ', & 'not enough memory? memory requested = ', IERROR 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 IF (SYM.EQ.0) THEN 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) ELSE POSELT_TOP = POSELT + int(NFRONT,8) & * int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) & + int((BEGS_BLR_L(CURRENT_BLR)-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('T' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDIF ENDDO ENDIF 100 CONTINUE #if defined(BLR_MT) !$OMP END SINGLE #endif END SUBROUTINE ZMUMPS_BLR_UPDATE_NELIM_VAR 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, K470, & COMPRESS_MID_PRODUCT, TOLEPS, 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, K470, & NELIM, NIV, SYM INTEGER, intent(out) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX(kind=8), TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, 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 CHARACTER(len=1) :: TRANSB1 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 write(*,*) 'Allocation problem in BLR routine & ZMUMPS_BLR_UPDATE_TRAILING: ', & 'not enough memory? memory requested = ', IERROR 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) IF (SYM.EQ.0) THEN IF (K470.EQ.1) THEN TRANSB1 = 'N' ELSE TRANSB1 = 'T' ENDIF CALL ZMUMPS_LRGEMM3(TRANSB1, 'T', MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, & KPERCENT, MID_RANK, BUILDQ) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), & TRANSB1, & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) ELSE CALL ZMUMPS_LRGEMM3('N', 'T', MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, & KPERCENT, MID_RANK, BUILDQ) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), 'N', & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING SUBROUTINE ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & LD_OR_NPIV, K470, & BEG_I_IN, END_I_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) :: NFRONT, 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) :: LD_OR_NPIV, K470 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN INTEGER :: IP, M, N, BIP, BEG_I, END_I #if defined(BLR_MT) INTEGER :: LAST_IP, CHUNK #endif INTEGER :: K, I INTEGER(8) :: POSELT_BLOCK, NFRONT8, 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 NFRONT8 = int(NFRONT,8) LD_BLK_IN_FRONT = NFRONT8 BIP = BEGS_BLR_FIRST_OFFDIAG #if defined(BLR_MT) LAST_IP = BEG_I CHUNK = 1 !$OMP PARALLEL DO PRIVATE(POSELT_BLOCK, M, N, K, I) !$OMP& FIRSTPRIVATE(BIP, LAST_IP) SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if defined(BLR_MT) DO I = 1, IP - LAST_IP IF (DIR .eq. 'V') THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ELSE IF (K470.EQ.1) THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ELSE BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N ENDIF ENDIF ENDDO LAST_IP = IP #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LD_OR_NPIV) THEN POSELT_BLOCK = POSELT + NFRONT8*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ELSE POSELT_BLOCK = POSELT +NFRONT8*int(LD_OR_NPIV,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LD_OR_NPIV,8)*int(BIP-1-LD_OR_NPIV,8) LD_BLK_IN_FRONT=int(LD_OR_NPIV,8) ENDIF ELSE POSELT_BLOCK = POSELT + & NFRONT8*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 K = BLR_PANEL(IP-CURRENT_BLR)%K IF ((BLR_PANEL(IP-CURRENT_BLR)%ISLR).AND. & (BLR_PANEL(IP-CURRENT_BLR)%LRFORM.EQ.1)) THEN IF (K.EQ.0) THEN IF (K470.NE.1.OR.DIR .eq. 'V') THEN DO I = 1, M 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 = 1, N A(POSELT_BLOCK+int(I-1,8)*NFRONT8: & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (K470.NE.1.OR.DIR .eq. 'V') THEN 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)) ELSE CALL zgemm('N', 'N', M, N, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & ZERO, A(POSELT_BLOCK), NFRONT) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (K470.NE.1.OR.DIR .eq. 'V') THEN DO I = 1, M 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 = 1, N A(POSELT_BLOCK+int(I-1,8)*NFRONT8: & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if !defined(BLR_MT) IF (DIR .eq. 'V') THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ELSE IF (K470.EQ.1) THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ELSE BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%N ENDIF ENDIF #endif END DO #if defined(BLR_MT) !$OMP END PARALLEL DO #endif END SUBROUTINE ZMUMPS_DECOMPRESS_PANEL SUBROUTINE ZMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR_L, NB_BLR_L, & BEGS_BLR_U, NB_BLR_U, NPARTSASS_U, & TOLEPS, NASS, NROW, & SYM, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, INODE, NIV, & LBANDSLAVE, ISHIFT,KPERCENT) INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, INODE INTEGER, INTENT(IN) :: NIV, NROW, KPERCENT INTEGER :: MAXI_CLUSTER, LWORK, SYM, NASS, & NB_BLR_L, NB_BLR_U, NPARTSASS_U DOUBLE PRECISION,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U COMPLEX(kind=8) :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER) DOUBLE PRECISION,DIMENSION(:) :: RWORK COMPLEX(kind=8), DIMENSION(:) :: WORK, TAU INTEGER, DIMENSION(:) :: JPVT INTEGER :: M, N, NCB, BEGLOOP, RANK, MAXRANK, FRONT_CB_BLR_SAVINGS INTEGER :: INFO, I, J, JJ, IB, JDEB, IS INTEGER :: allocok, MREQ INTEGER(8) :: POSELT_BLOCK DOUBLE PRECISION :: HR_COST, BUILDQ_COST, CB_DEMOTE_COST, & CB_PROMOTE_COST INTEGER T1, T2, COUNT_RATE DOUBLE PRECISION :: LOC_PROMOTING_TIME DOUBLE PRECISION :: LOC_CB_DEMOTING_TIME COMPLEX(kind=8), ALLOCATABLE :: R(:,:) COMPLEX(kind=8) :: ONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) LOC_PROMOTING_TIME = 0.0D0 LOC_CB_DEMOTING_TIME = 0.0D0 CB_DEMOTE_COST = 0.0D0 CB_PROMOTE_COST = 0.0D0 allocate(R(MAXI_CLUSTER,MAXI_CLUSTER),stat=allocok) IF (allocok .GT. 0) THEN MREQ=MAXI_CLUSTER*MAXI_CLUSTER write(*,*) 'Allocation problem in BLR routine & ZMUMPS_FAKE_COMPRESS_CB: ', & 'not enough memory? memory requested = ', MREQ CALL MUMPS_ABORT() ENDIF FRONT_CB_BLR_SAVINGS = 0 NCB = NFRONT - NASS IF (NCB.LE.0) RETURN IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF DO J = NPARTSASS_U+1, NB_BLR_U IF (NIV.EQ.1) THEN IF (SYM.GT.0) THEN BEGLOOP = J ELSE BEGLOOP = NPARTSASS_U + 1 ENDIF ELSE BEGLOOP = 2 ENDIF IF ((BEGS_BLR_U(J+1)+IS).LE.NASS+1) CYCLE JDEB = max(BEGS_BLR_U(J)+IS,NASS+1) N = BEGS_BLR_U(J+1)+IS-JDEB DO I = BEGLOOP, NB_BLR_L CALL SYSTEM_CLOCK(T1) JPVT = 0 M = BEGS_BLR_L(I+1)-BEGS_BLR_L(I) POSELT_BLOCK = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(I)-1),8) & + int(JDEB - 1,8) DO IB=1,M IF((I.EQ.J).AND.(SYM.GT.0).AND.(NIV.EQ.1)) THEN BLOCK(IB,1:IB) = & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : & POSELT_BLOCK+ & int((IB-1),8)*int(NFRONT,8)+int(IB-1,8) ) BLOCK(1:IB-1,IB) = BLOCK(IB,1:IB-1) ELSE BLOCK(IB,1:N) = & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8)+int(N-1,8) ) ENDIF END DO MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL ZMUMPS_TRUNCATED_RRQR( M, N, BLOCK(1,1), & MAXI_CLUSTER, JPVT(1), TAU(1), WORK(1), N, & RWORK(1), TOLEPS, RANK, MAXRANK, INFO ) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_CB_DEMOTING_TIME = LOC_CB_DEMOTING_TIME & + DBLE(T2-T1)/DBLE(COUNT_RATE) IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK & IN CB (FAKE COMPRESSION anyway) " CALL MUMPS_ABORT() END IF HR_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(RANK)/3.0D0 & + 4.0D0*dble(RANK)*dble(M)*dble(N) & - 2.0D0*dble((M+N))*dble(RANK)*dble(RANK) IF (RANK.LE.MAXRANK) THEN CALL SYSTEM_CLOCK(T1) DO JJ=1, N R(1:MIN(RANK,JJ),JPVT(JJ)) = & BLOCK(1:MIN(RANK,JJ),JJ) IF(JJ.LT.RANK) R(MIN(RANK,JJ)+1: & RANK,JPVT(JJ))= ZERO END DO CALL zungqr(M, RANK, RANK, & BLOCK(1,1), MAXI_CLUSTER, & TAU(1), WORK(1), LWORK, INFO) CALL zgemm('T', 'T', N, M, RANK, ONE , & R , MAXI_CLUSTER, & BLOCK(1,1) , MAXI_CLUSTER, & ZERO, A(POSELT_BLOCK), NFRONT) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) BUILDQ_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(M) & - dble(RANK)*dble(RANK)*dble(RANK) & CB_DEMOTE_COST = CB_DEMOTE_COST + & (HR_COST+BUILDQ_COST) CB_PROMOTE_COST = CB_PROMOTE_COST + & 2.0D0*dble(RANK)*dble(M)*dble(N) FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & (M-RANK)*(N-RANK)-RANK*RANK ELSE CB_DEMOTE_COST = CB_DEMOTE_COST + HR_COST END IF END DO END DO deallocate(R) CALL STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS) CALL UPDATE_FLOP_STATS_CB_DEMOTE(CB_DEMOTE_COST, NIV) CALL UPDATE_FLOP_STATS_CB_PROMOTE(CB_PROMOTE_COST, NIV) CALL UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME) CALL UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME) END SUBROUTINE ZMUMPS_FAKE_COMPRESS_CB SUBROUTINE ZMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, K473, BLR_PANEL, CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & K470, KEEP8, K480, & 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, CURRENT_BLR, NIV INTEGER, intent(out) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) COMPLEX(kind=8), intent(inout) :: A(LA) DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK COMPLEX(kind=8), TARGET, DIMENSION(:,:) :: BLOCK COMPLEX(kind=8), TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER, POINTER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, K470 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 IF (K470.EQ.1) THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE M = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF 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 = 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 (DIR .eq. 'V') THEN M = BEGS_BLR(IP+1)-BEGS_BLR(IP) POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE IF (K470.EQ.1) THEN M = BEGS_BLR(IP+1)-BEGS_BLR(IP) ELSE N = BEGS_BLR(IP+1)-BEGS_BLR(IP) ENDIF POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) END IF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF IF (K470.NE.1.OR.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, 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, RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE BLR_PANEL(IP-CURRENT_BLR)%Q = ZERO DO I=1,RANK BLR_PANEL(IP-CURRENT_BLR)%Q(I,I) = ONE END DO CALL zunmqr & ('L', 'N', M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), & M, WORK_THR(1), LWORK, INFO ) IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNMQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF 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 UPDATE_FLOP_STATS_DEMOTE( & BLR_PANEL(IP-CURRENT_BLR), NIV) END IF ELSE IF (K470.NE.1.OR.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 CALL UPDATE_FLOP_STATS_DEMOTE(BLR_PANEL(IP-CURRENT_BLR), & NIV) ENDIF BLR_PANEL(IP-CURRENT_BLR)%K = -1 END IF END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE ZMUMPS_COMPRESS_PANEL END MODULE ZMUMPS_FAC_LR MUMPS_5.1.2/src/zend_driver.F0000664000175000017500000003156413164366266016163 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) 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%PROCNODE)) THEN DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) 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 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 -------------- C Receive buffer C -------------- IF ( associated( id%BUFR ) ) DEALLOCATE( id%BUFR ) NULLIFY( id%BUFR ) 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_AFTER_L0_OMP)) THEN DEALLOCATE(id%IPOOL_AFTER_L0_OMP) NULLIFY(id%IPOOL_AFTER_L0_OMP) END IF IF (associated(id%IPOOL_BEFORE_L0_OMP)) THEN DEALLOCATE(id%IPOOL_BEFORE_L0_OMP) NULLIFY(id%IPOOL_BEFORE_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%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 RETURN END SUBROUTINE ZMUMPS_END_DRIVER MUMPS_5.1.2/src/dfac_process_maprow.F0000664000175000017500000014263613164366263017670 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif IMPLICIT NONE INCLUDE 'dmumps_root.h' #if ! defined(NO_FDM_MAPROW) #endif TYPE (DMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ) 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 ) 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 COMPRESSCB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE, TYPESPLIT INTEGER KEEP253_LOC #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 IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE_PERE)), & SLAVEF) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in DMUMPS_MAPLIG' 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)), & SLAVEF ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) write(LP,*) MYID, & ' : PB allocation NBROW in DMUMPS_MAPLIG' 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)), & SLAVEF) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 7 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO #endif ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 9 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO_SYM #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM 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( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) 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 COMPRESSCB=(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 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(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & A(PTRAST(STEP(ISON))), I, PDEST, PDEST_MASTER, & COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, COMPRESSCB, & KEEP253_LOC ) 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, NBPROCFILS, 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF ITYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), SLAVEF) 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, MYID, COMM, KEEP,KEEP8, DKEEP,ITYPE & ) 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 &) 600 CONTINUE DEALLOCATE(PERM) 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 40 ), 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 INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ) 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 NBPROCFILS( KEEP(28) ) 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 ) 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) :: APOS, POSROW, ASIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL COMPRESSCB INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM 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)), & SLAVEF ) 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(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ': PB allocation PERM in DMUMPS_MAPLIG_FILS_NIV1' 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( 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)) 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 COMPRESSCB=(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 DECR=1 NBPROCFILS(STEP(INODE_PERE)) = & NBPROCFILS(STEP(INODE_PERE)) - DECR NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR #if ! defined(NO_XXNBPR) IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE_PERE)), & IW(PTLUST(STEP(INODE_PERE))+XXNBPR)) IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXNBPR)) #endif DO II = 1,NROWS_TO_STACK IROW_SON=PERM(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 (COMPRESSCB) THEN IF (NELIM.EQ.0) THEN POSROW = PAMASTER(STEP(ISON)) + & int(IROW_SON,8)*int(IROW_SON-1,8)/2_8 ELSE POSROW = PAMASTER(STEP(ISON)) + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ENDIF ELSE POSROW = PAMASTER(STEP(ISON)) + & 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 CALL DMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF) ENDDO IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (COMPRESSCB) THEN POSROW = PAMASTER(STEP(ISON)) & + 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 = PAMASTER(STEP(ISON)) + & 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).GT. 0 ) THEN CALL DMUMPS_COMPUTE_MAXPERCOL( & A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253), & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB, & NELIM+NBROW(1)) ELSE CALL DMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF CALL DMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXNBPR)) IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 #endif & ) 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 ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE_PERE)), & IW(PTLUST(STEP(INODE_PERE))+XXNBPR)) IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 #endif & ) THEN CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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)) APOS = PAMASTER(STEP(ISON)) 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 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(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & A(APOS), I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & COMPRESSCB, KEEP(253)) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 DMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) 600 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(MAP) DEALLOCATE(PERM) DEALLOCATE(SLAVES_PERE) RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 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, NBPROCFILS, & 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, & FILS, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL & ) USE DMUMPS_BUF, ONLY: DMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE DMUMPS_LOAD, ONLY : DMUMPS_LOAD_POOL_UPD_NEW_POOL INTEGER ICNTL(40) 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(inout) :: NBPROCFILS( KEEP(28) ) 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 INTEGER, intent(in) :: FILS(N) 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 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 LOGICAL :: COMPRESSCB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) #if ! defined(NO_XXNBPR) INTEGER :: INBPROCFILS_SON #endif 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 NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - DECR #if ! defined(NO_XXNBPR) IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR #endif IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR #if ! defined(NO_XXNBPR) IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR #endif 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 COMPRESSCB = (IW(ISTCHK+XXS).EQ.S_CB1COMP) CALL MUMPS_GETI8(SIZFR, IW(ISTCHK+XXR)) IF (IW(ISTCHK+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 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 ) 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 ) ENDIF ENDIF DO II = 1,NROWS_TO_STACK 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 ( COMPRESSCB ) THEN IF (NBCOLS - NROW .EQ. 0 ) THEN ITMP = IROW_SON POSROW = PTRAST(STEP(ISON))+ & int(ITMP,8) * int(ITMP-1,8) / 2_8 ELSE ITMP = IROW_SON + NBCOLS - NROW POSROW = PTRAST(STEP(ISON)) & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ENDIF ELSE POSROW = PTRAST(STEP(ISON)) + 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 CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.COMPRESSCB).AND.(IS_ofType5or6) ) THEN CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) ENDIF ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV 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) & .OR. & ( (KEEP(50).NE.0).and. (.NOT.COMPRESSCB) ) & ) & ) THEN CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - & NROWS_TO_STACK #if ! defined(NO_XXNBPR) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK #endif EXIT ELSE CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) NBPROCFILS(STEP(IFATH)) = & NBPROCFILS(STEP(IFATH)) - 1 #if ! defined(NO_XXNBPR) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 #endif ENDIF ENDIF ENDDO IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (COMPRESSCB) THEN WRITE(*,*) "Error 1 in PARPIV/DMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = PTRAST(STEP(ISON))+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 .NE. 0 ) THEN CALL DMUMPS_COMPUTE_MAXPERCOL( & A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, LMAP_LOC-NBROW(1)+1-KEEP253_LOC, & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB,ITMP) ELSE CALL DMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF CALL DMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB #if ! defined(NO_XXNBPR) 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 #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL( NBPROCFILS(STEP(ISON)), & IW(INBPROCFILS_SON) ) IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN #else IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN #endif 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 DMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, & ISTCHK_LOC, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL( NBPROCFILS(STEP(IFATH)), & IW(PTLUST(STEP(IFATH))+XXNBPR) ) IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 #else IF ( NBPROCFILS(STEP(IFATH)) .EQ. 0 #endif & ) THEN CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, 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.1.2/src/sfac_driver.F0000664000175000017500000037004113164366266016133 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_CORE USE SMUMPS_LR_STATS USE SMUMPS_LR_DATA_M, only: SMUMPS_BLR_INIT_MODULE, & SMUMPS_BLR_END_MODULE 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 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 C Explicit interface needed because C of "id" derived datatype argument 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 C 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(8) ::KEEP826_SAVE INTEGER(8) K67 INTEGER(8) K68,K69 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF INTEGER SMUMPS_LBUF, SMUMPS_LBUFR_BYTES, SMUMPS_LBUF_INT INTEGER(8) SMUMPS_LBUFR_BYTES8, SMUMPS_LBUF8 INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, NSTEPS, K28, LPOOL, LIW INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 REAL CNTL4 INTEGER MIN_PERLU, MAXIS_ESTIM INTEGER MAXIS INTEGER(8) :: MAXS 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 INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER LIWK, LWK_REAL INTEGER(8) :: LWK C SLAVE: used to determine if proc has the role of a slave LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED C WK_USER_PROVIDED is set to true when workspace WK_USER is provided by user REAL :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2 REAL :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER FRONTWISE C temporary variable for collecting stats from all processors DOUBLE PRECISION :: TMP_GLOBAL_BLR_SAVINGS DOUBLE PRECISION :: TMP_ACC_FR_MRY DOUBLE PRECISION :: TMP_ACC_LR_FLOP_GAIN DOUBLE PRECISION :: TMP_ACC_FLOP_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_PANEL DOUBLE PRECISION :: TMP_ACC_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_ACC_FLOP_LR_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_FR_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_LR_UPDT DOUBLE PRECISION :: TMP_ACC_FLOP_LR_UPDT_OUT DOUBLE PRECISION :: TMP_ACC_FLOP_RMB DOUBLE PRECISION :: TMP_ACC_FLOP_DEC_ACC DOUBLE PRECISION :: TMP_ACC_FLOP_REC_ACC DOUBLE PRECISION :: TMP_ACC_FLOP_FR_UPDT DOUBLE PRECISION :: TMP_ACC_FLOP_DEMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_CB_DEMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_CB_PROMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_FR_FACTO INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_ACC_UPDT_TIME DOUBLE PRECISION :: TMP_ACC_DEMOTING_TIME DOUBLE PRECISION :: TMP_ACC_CB_DEMOTING_TIME DOUBLE PRECISION :: TMP_ACC_PROMOTING_TIME DOUBLE PRECISION :: TMP_ACC_FRPANELS_TIME DOUBLE PRECISION :: TMP_ACC_FAC_I_TIME DOUBLE PRECISION :: TMP_ACC_FAC_MQ_TIME DOUBLE PRECISION :: TMP_ACC_FAC_SQ_TIME DOUBLE PRECISION :: TMP_ACC_TRSM_TIME DOUBLE PRECISION :: TMP_ACC_FRFRONTS_TIME DOUBLE PRECISION :: TMP_ACC_LR_MODULE_TIME 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 C C External references C =================== INTEGER numroc EXTERNAL numroc C Fwd in facto: REAL, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_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 C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS 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 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 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 ) IF ( PROKG .and. KEEP(53).GT.0 ) THEN WRITE(MPG,'(/A,I3)') ' Null space option :', KEEP(19) IF ( KEEP(21) .ne. N ) THEN WRITE( MPG, '(A,I10)') ' Max deficiency : ', KEEP(21) END IF IF ( KEEP(22) .ne. 0 ) THEN WRITE( MPG, '(A,I10)') ' Min deficiency : ', KEEP(22) END IF END IF 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 !Later: .GT. to allow ICNTL(22)=-1 # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(480).NE.0) THEN id%KEEP(480) = 0 IF (PROK) & write(MP,'(A)') & ' MUMPS is not compiled with -DBLR_LUA ', & ' => Resetting KEEP(480) to 0' ENDIF IF (id%KEEP(475).NE.0) THEN id%KEEP(475) = 0 IF (PROK) & write(MP,'(A)') & ' MUMPS is not compiled with -DLRTRSM ', & ' => Resetting KEEP(475) to 0' 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 ) IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & " Internal ERROR with BLR setting " WRITE(MPG,'(A)') " BLR was not activated during ", & " analysis and is requested during factorization. " id%INFO(1)=-900 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(470), 23, MPI_INTEGER, & MASTER, id%COMM, IERR ) 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 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 C 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 C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL(1) = 0.0 C --------------------------------------- IF ( KEEP(50) .eq. 1 ) THEN IF (id%CNTL(1) .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') &' ** Warning : SPD solver called, resetting CNTL(1) to 0.0E0' END IF END IF id%CNTL(1) = ZERO END IF 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 (PROKG) WRITE(MPG,'(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 (PROKG) WRITE(MPG,'(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 (PROKG) WRITE(MPG,'(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 IF ( PROKG ) THEN WRITE( MPG, 172 ) id%NSLAVES, id%ICNTL(22), & id%KEEP8(111), KEEP(126), KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, id%CNTL(1) IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) 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 530 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL)) 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 530 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) 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 530 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,*) 'ERREUR 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)) RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 530 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 -Rank revealing on the Schur (ICNTL(16)/KEEP(19)) C CNTL(6) is used to set SEUIL and SEUIL_LDLT_NIV2 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. C Note that SEUIL* might be reset later in this routine C but only when static pivoting is on C which will be excluded if null pivots or C rank-revealing (RR) is on C ----------------------------------------------- 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) CNTL1 = id%CNTL(1) CALL MPI_BCAST(CNTL1, 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) 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 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).EQ.0) THEN C -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO ELSE C -- RR is on C July 2012 C CNTL(3) is the threshold used in the following C to compute the SEUIL used for postponing pivots to root C SEUIL*CNTL(6) is then the treshold for null pivot detection C (with 0< CNTL(6) <= 1) IF (CNTL3 .LT. ZERO) THEN SEUIL = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN SEUIL = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN SEUIL = N*EPS*ANORMINF ! standard articles ENDIF IF (PROKG) WRITE(MPG,*) & ' ABSOLUTE PIVOT THRESHOLD for rank revealing =',SEUIL ENDIF C After QR with pivoting of root or SVD, diagonal entries C need be analysed to determine null space vectors. C Two strategies are provided : id%DKEEP(9) = SEUIL IF (id%DKEEP(10).LT.MONE) THEN id%DKEEP(10)=MONE ELSEIF((id%DKEEP(10).LE.ONE).AND.(id%DKEEP(10).GE.ZERO)) THEN id%DKEEP(10)=1000.0E0 ENDIF SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN 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 IF (ANORMINF.EQ.ZERO) & CALL SMUMPS_ANORMINF( id , ANORMINF, LSCAL ) IF (KEEP(19).NE.0) THEN C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed. C Pivot rows smaller than DKEEP(1) are directly added to null space C and thus considered as null pivot rows. Thus we define id%DKEEP(1) C relatively to SEUIL (which is based on CNTL(3)) IF (CNTL(6).GT.0.AND.CNTL(6).LT.1) THEN C we want DKEEP(1) < SEUIL id%DKEEP(1) = SEUIL*CNTL(6) ELSE id%DKEEP(1) = SEUIL* 0.01E0 ENDIF ELSE 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 id%DKEEP(1) = 1.0E-5*EPS*ANORMINF ENDIF ENDIF IF (PROKG) WRITE(MPG,*) & ' ZERO PIVOT DETECTION ON, THRESHOLD =',id%DKEEP(1) IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,*) & ' 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 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%NSLAVES) 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 C and in case of rank revealing 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 530 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 C -- Set KEEP(97) and compute static pivoting threshold. 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 ) C WRITE(*,*) id%MYID,': ANORMINF',ANORMINF ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE C WRITE(*,*) 'id%CNTL(4)',id%CNTL(4) 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 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 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C Allocate S on all nodes C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN C In-core MAXS_BASE8=id%KEEP8(12) ELSE C OOC or no factors stored MAXS_BASE8=id%KEEP8(14) ENDIF IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ELSE IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) C If PERLU < 0, we may obtain a C null or negative value of MAXS. IF (MAXS_BASE_RELAXED8 > huge(MAXS)) THEN C id%INFO(1)=-37 C id%INFO(2)=int(MAXS_BASE_RELAXED8/1000000_8) WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ENDIF MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) MAXS = MAXS_BASE_RELAXED8 C Note that in OOC this value of MAXS will be C overwritten if KEEP(96) .NE. 0 or if C ICNTL(23) (that is, KEEP8(4)) is provided. ELSE MAXS = 1_8 MAXS_BASE_RELAXED8 = 1_8 END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF C C If KEEP(96) is provided, C use it without asking questions C IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C C IF (KEEP(96).GT.0) THEN C -- useful mostly for internal testing: C -- we can force in this way a given value C -- of MAXS and forget about other input values C -- such as ICNTL(23) (KEEP8(4)/1E6) C -- that could change MAXS value. MAXS=int(KEEP(96),8) ELSE IF (id%KEEP8(4) .NE. 0_8) THEN C ------------------------- C WE TRY TO USE MEM_ALLOWED (KEEP8(4)/1E6) C ------------------------- C First compute what we have: TOTAL_MBYTES(PERLU) C and TOTAL_BYTES(PERLU) C PERLU_ON = .TRUE. CALL SMUMPS_MAX_MEM( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, & id%KEEP8(28), id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., KEEP(201), & PERLU_ON, TOTAL_BYTES) C C Assuming that TOTAL_BYTES is due to MAXS rather than C to the temporary buffers used for the distribution of C the matrix on the slaves (arrowheads or element distrib), C then we have: C C KEEP8(4)-TOTAL_BYTES is the extra free space C C A simple algorithm to redistribute the extra space: C All extra freedom (it could be negative !) is added to MAXS: MAXS_BASE_RELAXED8=MAXS_BASE_RELAXED8 + & (id%KEEP8(4)-TOTAL_BYTES)/int(KEEP(35),8) IF (MAXS_BASE_RELAXED8 > int(huge(MAXS),8)) THEN WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ELSE IF (MAXS_BASE_RELAXED8 .LE. 0_8) THEN C We need more space in order to at least enough id%INFO(1)=-9 IF ( -MAXS_BASE_RELAXED8 .GT. & int(huge(id%INFO(1)),8) ) THEN WRITE(*,*) "I8: OVERFLOW" CALL MUMPS_ABORT() ENDIF id%INFO(2)=-int(MAXS_BASE_RELAXED8) ELSE MAXS=MAXS_BASE_RELAXED8 ENDIF ENDIF ENDIF ENDIF ! I_AM_SLAVE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF CALL SMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & id%COMM, "effective relaxed size of S =") C Next PROPINFO is there for possible negative C values of MAXS resulting from small MEM_ALLOWED CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN C We jump after the call to LOAD_END and OOC_END since we didn't C called yet OOC_INIT and LOAD_INIT GOTO 530 ENDIF IF ( I_AM_SLAVE ) THEN C ------------------ C Dynamic scheduling C ------------------ CALL SMUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), KEEP(66), 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)-TOTAL_BYTES 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 #if ! defined(OLD_LOAD_MECHANISM) 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)) #endif IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 ! reset space allocated to zero ENDIF #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN 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 ELSE id%S => id%WK_USER(1:id%KEEP8(24)) 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 CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) CALL MUMPS_FDM_INIT('F',NB_ACTIVE_FRONTS_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_ACTIVE_FRONTS_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 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 C ---------------------------------------- IF (KEEP(38).NE.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 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) IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF 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 ) ) 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, id%I_AM_CAND, & id%CANDIDATES) C 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 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 ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) 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), id%S(1), MAXS, & 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, & & id%S(1), MAXS, & 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, & id%S(1), MAXS, 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), & id%S(1), MAXS, 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) TIME 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 slaves 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 integers, since byte is not C a standard datatype. C We now use KEEP(43) and KEEP(44) as estimated at analysis C to allocate appropriate buffer sizes. C C Reception buffer C ---------------- SMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP( 35 ), 8) C ------------------- C Ensure a reasonable C 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 PERLU = KEEP( 12 ) C For hybrid scheduling (strategy 5), Abdou C wants a minimal amount of freedom even for C small/negative PERLU values. 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(43))-100,8)) SMUMPS_LBUFR_BYTES = int( SMUMPS_LBUFR_BYTES8 ) IF (KEEP(48)==5) THEN C Since the buffer is 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 ----------- SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(43)) * real(KEEP(35)), 8 ) 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%NSLAVES ) 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 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 the 2 send buffers 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 CALL SMUMPS_BUF_ALLOC_CB( SMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= SMUMPS_LBUF id%INFO(2)= (SMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error in SMUMPS_BUF_ALLOC_CB' & ,id%INFO(2) ENDIF GO TO 110 END IF C ----------------------------- C Allocate reception buffer and C keep it in the structure C ----------------------------- id%LBUFR_BYTES = SMUMPS_LBUFR_BYTES id%LBUFR = (SMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) IF (associated(id%BUFR)) DEALLOCATE(id%BUFR) ALLOCATE( id%BUFR( id%LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%LBUFR NULLIFY(id%BUFR) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%BFUR(', id%LBUFR,')', IERR ENDIF GO TO 110 END IF C C The buffers are declared INTEGER, because BYTE is not a C standard data type. The sizes are in bytes, so we allocate C a number of INTEGERs. The allocated size in integer is the C size in bytes divided by KEEP(34) C ------------------------------- C Allocate IS. IS will contain C factors and contribution blocks C ------------------------------- C Relax workspace at facto now C PERLU might have been modified reload initial value 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 + 2 * max(PERLU,10) * & ( MAXIS_ESTIM / 100 + 1 ) & ) IF (associated(id%IS)) DEALLOCATE( id%IS ) ALLOCATE( id%IS( MAXIS ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=MAXIS NULLIFY(id%IS) IF (LPOK) THEN WRITE(*,*) id%MYID,': Allocation error for id%IS(',MAXIS,')' ENDIF GO TO 110 END IF LIW = MAXIS C ----------------------- C Allocate PTLUST_S. PTLUST_S C is used by solve later C ----------------------- IF (associated( id%PTLUST_S )) DEALLOCATE(id%PTLUST_S) 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 100 END IF IF (associated( id%PTRFAC )) DEALLOCATE(id%PTRFAC) 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 100 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 + 3 * 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 C Store size of receive buffers in module CALL SMUMPS_BUF_DIST_IRECV_SIZE( id%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 SPMD C PERLU_ON = .TRUE. CALL SMUMPS_MAX_MEM( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) id%INFO(16) = TOTAL_MBYTES IF ( PROK ) THEN WRITE(MP,'(A,I10) ') & ' ** Space in MBYTES used during factorization :', & id%INFO(16) END IF C C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in bytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in bytes for facto, C sum over all processors C ---------------------------------------------------- C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Memory relaxation parameter ( ICNTL(14) ) :', & KEEP(12) WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for facto :', & id%INFOG(18) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during facto :', & ( id%INFOG(19)-id%INFO(16) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during facto :', & id%INFOG(19) / id%NSLAVES END IF 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 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 CALL SMUMPS_FAC_B( id%N, NSTEPS,id%S(1),MAXS,id%IS(1),LIW, & 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, id%BUFR(1),id%LBUFR, & id%LBUFR_BYTES, 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) & ) IF ( PROK .and. KEEP(38) .ne. 0 ) THEN WRITE( MP, 175 ) KEEP(49) END IF 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 ---------------- DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) 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 C next line should be enough but ... C DEALLOCATE( id%DBLARR ) 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 send buffers C They will be reallocated C in the solve. C ------------------------ IF (associated(id%BUFR)) THEN DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) END IF CALL SMUMPS_BUF_DEALL_CB( IERR ) 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 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) IF ( PROKG ) THEN IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) TIME ELSE WRITE(MPG,185) TIME ENDIF ENDIF ENDIF CC Made available to users on release 4.4 (April 2005) PERLU_ON = .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), & PERLU_ON, TOTAL_BYTES) 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 IF (PROK ) THEN WRITE(MP,'(A,I10) ') & ' ** Effective minimum Space in MBYTES for facto :', & TOTAL_MBYTES ENDIF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K69 = id%KEEP8(69) ELSE K67 = 0_8 K68 = 0_8 K69 = 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 CALL SMUMPS_AVGMAX_STAT8(PROKG, MPG, K67, id%NSLAVES, & id%COMM, "effective space used in S (KEEP8(67)) =") C C ---------------------------------------------------- C Centralize memory statistics on the host C C INFOG(21) = size of mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & TOTAL_MBYTES, id%INFOG(21), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Rank of processor needing largest memory :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Space in MBYTES used by this processor :', & id%INFOG(21) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Avg. Space in MBYTES per working proc :', & ( id%INFOG(22)-TOTAL_MBYTES ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Avg. Space in MBYTES per working proc :', & id%INFOG(22) / id%NSLAVES END IF END IF * save statistics in KEEP array. KEEP(33) = id%INFO(11) ! this should be the other way round C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations 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(6), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(6), INFOG(9)) CALL MPI_REDUCE( id%INFO(10), INFOG(10), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) 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 ============================== C LOW-RANK C ============================== IF ( KEEP(486) .GT. 0 ) THEN !LR is activated CALL MPI_REDUCE( GLOBAL_BLR_SAVINGS, TMP_GLOBAL_BLR_SAVINGS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FR_MRY, TMP_ACC_FR_MRY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_LR_FLOP_GAIN, TMP_ACC_LR_FLOP_GAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_TRSM, TMP_ACC_FLOP_FR_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_TRSM, TMP_ACC_FLOP_LR_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_UPDT, TMP_ACC_FLOP_FR_UPDT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_UPDT, TMP_ACC_FLOP_LR_UPDT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_RMB, TMP_ACC_FLOP_RMB & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_UPDT_OUT, & TMP_ACC_FLOP_LR_UPDT_OUT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_DEC_ACC, TMP_ACC_FLOP_DEC_ACC & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_REC_ACC, TMP_ACC_FLOP_REC_ACC & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_TRSM, TMP_ACC_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_PANEL, TMP_ACC_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FRFRONTS, TMP_ACC_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_DEMOTE, TMP_ACC_FLOP_DEMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_CB_DEMOTE, TMP_ACC_FLOP_CB_DEMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_CB_PROMOTE,TMP_ACC_FLOP_CB_PROMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_FACTO,TMP_ACC_FLOP_FR_FACTO & , 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 ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN & + ACC_FLOP_DEMOTE + ACC_FLOP_FRFRONTS CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,AVG_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_ACC_FLOP_LR_FACTO = AVG_ACC_FLOP_LR_FACTO/id%NPROCS ENDIF CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,MIN_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,MAX_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( ACC_UPDT_TIME,TMP_ACC_UPDT_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_DEMOTING_TIME,TMP_ACC_DEMOTING_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_CB_DEMOTING_TIME, & TMP_ACC_CB_DEMOTING_TIME, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, MASTER, & id%COMM, IERR) CALL MPI_REDUCE( ACC_PROMOTING_TIME,TMP_ACC_PROMOTING_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FRPANELS_TIME,TMP_ACC_FRPANELS_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_I_TIME,TMP_ACC_FAC_I_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_MQ_TIME,TMP_ACC_FAC_MQ_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_SQ_TIME,TMP_ACC_FAC_SQ_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_TRSM_TIME,TMP_ACC_TRSM_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FRFRONTS_TIME,TMP_ACC_FRFRONTS_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_LR_MODULE_TIME,TMP_ACC_LR_MODULE_TIME & , 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 GLOBAL_BLR_SAVINGS = TMP_GLOBAL_BLR_SAVINGS ACC_FR_MRY = TMP_ACC_FR_MRY ACC_LR_FLOP_GAIN = TMP_ACC_LR_FLOP_GAIN ACC_FLOP_TRSM = TMP_ACC_FLOP_TRSM ACC_FLOP_PANEL = TMP_ACC_FLOP_PANEL ACC_FLOP_LR_TRSM = TMP_ACC_FLOP_LR_TRSM ACC_FLOP_FR_TRSM = TMP_ACC_FLOP_FR_TRSM ACC_FLOP_LR_UPDT = TMP_ACC_FLOP_LR_UPDT ACC_FLOP_LR_UPDT_OUT = TMP_ACC_FLOP_LR_UPDT_OUT ACC_FLOP_RMB = TMP_ACC_FLOP_RMB ACC_FLOP_DEC_ACC = TMP_ACC_FLOP_DEC_ACC ACC_FLOP_REC_ACC = TMP_ACC_FLOP_REC_ACC ACC_FLOP_FR_UPDT = TMP_ACC_FLOP_FR_UPDT ACC_FLOP_DEMOTE = TMP_ACC_FLOP_DEMOTE ACC_FLOP_CB_DEMOTE = TMP_ACC_FLOP_CB_DEMOTE ACC_FLOP_CB_PROMOTE = TMP_ACC_FLOP_CB_PROMOTE ACC_FLOP_FRFRONTS = TMP_ACC_FLOP_FRFRONTS CNT_NODES = TMP_CNT_NODES ACC_FLOP_FR_FACTO = TMP_ACC_FLOP_FR_FACTO C ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN C & + ACC_FLOP_DEMOTE ACC_UPDT_TIME = TMP_ACC_UPDT_TIME /id%NPROCS ACC_DEMOTING_TIME = TMP_ACC_DEMOTING_TIME /id%NPROCS ACC_CB_DEMOTING_TIME = TMP_ACC_CB_DEMOTING_TIME/id%NPROCS ACC_PROMOTING_TIME = TMP_ACC_PROMOTING_TIME /id%NPROCS ACC_FRPANELS_TIME = TMP_ACC_FRPANELS_TIME /id%NPROCS ACC_FAC_I_TIME = TMP_ACC_FAC_I_TIME /id%NPROCS ACC_FAC_MQ_TIME = TMP_ACC_FAC_MQ_TIME /id%NPROCS ACC_FAC_SQ_TIME = TMP_ACC_FAC_SQ_TIME /id%NPROCS ACC_TRSM_TIME = TMP_ACC_TRSM_TIME /id%NPROCS ACC_FRFRONTS_TIME = TMP_ACC_FRFRONTS_TIME /id%NPROCS ACC_LR_MODULE_TIME = TMP_ACC_LR_MODULE_TIME /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110),RINFOG(3),id%NPROCS, & PROKG, MPG) FRONTWISE = 0 IF (id%KEEP(486).EQ.1) THEN C BLR was activated 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, & 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), KEEP(485), KEEP(467), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) ELSE RINFOG(14) = 0.0E00 ENDIF 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 C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(16). C Note that KEEP(17) already has the same value on all procs INFOG(28)=KEEP(112)+KEEP(17) 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 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),id%KEEP8(6),INFOG(10), & 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(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency 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 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 #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 CALL SMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8, .TRUE.) C INFO(1): input only ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') CALL MUMPS_FDM_END('F') 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 530 is done when an error occurs before C the calls to 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 FOR MATRIX DISTRIBUTION =',F12.4) 166 FORMAT(' Convergence error after scaling 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/ & ' REAL SPACE FOR FACTORS =',I16/ & ' INTEGER SPACE FOR FACTORS =',I16/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I16) 172 FORMAT(/' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' NUMBER OF WORKING PROCESSES =',I16/ & ' OUT-OF-CORE OPTION (ICNTL(22)) =',I16/ & ' REAL SPACE FOR FACTORS =',I16/ & ' INTEGER SPACE FOR FACTORS =',I16/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I16/ & ' NUMBER OF NODES IN THE TREE =',I16/ & ' MEMORY ALLOWED (MB -- 0: N/A ) =',I16/ & ' RELATIVE THRESHOLD FOR PIVOTING, CNTL(1) =',D16.4) 173 FORMAT( ' PERFORM FORWARD DURING FACTO, NRHS =',I16) 175 FORMAT(/' NUMBER OF ENTRIES FOR // ROOT =',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) =',F12.4) 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 NULL PIVOTS DETECTED BY ICNTL(16) =',I16) 99991 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(24) =',I16) 99992 FORMAT( ' INFOG(28) ESTIMATED DEFICIENCY =',I16) 99984 FORMAT(/' GLOBAL STATISTICS '/ & ' RINFOG(2) OPERATIONS IN NODE ASSEMBLY =',1PD10.3/ & ' ------(3) OPERATIONS IN NODE ELIMINATION=',1PD10.3/ & ' 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 SUBROUTINE SMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL PROKG INTEGER MPG INTEGER(8) VAL INTEGER NSLAVES INTEGER COMM CHARACTER*42 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 WRITE(MPG,100) " Maximum ", MSG, MAX_VAL WRITE(MPG,100) " Average ", MSG, int(AVG_VAL,8) ENDIF RETURN 100 FORMAT(A9,A42,I16) 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%NSLAVES) 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.1.2/src/cmumps_ooc.F0000664000175000017500000036057613164366265016023 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' 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 #if ! defined (OOC_DEBUG) PTRFAC(STEP_OOC(INODE))=-777777_8 #endif 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 #if ! defined (OOC_DEBUG) PTRFAC(STEP_OOC(INODE))=-777777_8 #endif 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' 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))), & SLAVEF_OOC ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & SLAVEF_OOC ) 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)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),SLAVEF_OOC).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)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),SLAVEF_OOC).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) 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 #if ! defined(TEMP_VERSION_TO_FORCE_DATA_REINIT) & .OR. KEEP_OOC(50).NE.0 #endif & ) 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 #if ! defined(TEMP_VERSION_TO_FORCE_DATA_REINIT) & .OR. KEEP_OOC(50).NE.0 #endif & ) 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) & WRITE(ICNTL1,*) 'PB allocation in CMUMPS_STRUC_STORE_FILE_NAME' 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) & WRITE(ICNTL1,*) & 'PB allocation in CMUMPS_STRUC_STORE_FILE_NAME' 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) & WRITE(ICNTL1,*) & 'PB allocation in CMUMPS_OOC_OPEN_FILES_FOR_SOLVE' 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) 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.1.2/src/smumps_driver.F0000664000175000017500000025522213164366266016546 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 -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, 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). These 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. * * 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. 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. * Other values for the parameter JOB can invoke combinations of these * three basic operations. 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_8) THEN id%KEEP8(29) = id%NNZ_loc ELSE id%KEEP8(29) = int(id%NZ_loc, 8) ENDIF ENDIF C C IF (JOB.EQ.-2.OR.JOB.EQ.1.OR.JOB.EQ.2.OR.JOB.EQ.3.OR. & JOB.EQ.4.OR.JOB.EQ.5.OR.JOB.EQ.6 & ) THEN C Correct value of JOB C ICNTL should have been initialized and can be used LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%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 (id%KEEP(500).EQ.1) THEN FROM_C_INTERFACE_STRING=" from C interface" ELSE FROM_C_INTERFACE_STRING=" " ENDIF IF (PROKG) THEN C Print basic information on MUMPS call IF (JOB .EQ. -2 & ) THEN C N, NELT, NNZ not meaningful WRITE(MPG,'(/A,A,A,A,I4,I12)') & 'Entering SMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB =', JOB ELSE IF (id%ICNTL(5) .NE. 1) THEN C Assembled format IF (id%ICNTL(18) .EQ. 0 & ) THEN WRITE(MPG,'(/A,A,A,A,I4,I12,I15)') & 'Entering SMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB, N, NNZ =', JOB,id%N,id%KEEP8(28) ELSE WRITE(MPG,'(/A,A,A,A,I4,I12)') & 'Entering SMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' with JOB, N =', JOB,id%N ENDIF ELSE C Elemental format WRITE(MPG,'(/A,A,A,A,I4,I12,I15)') & 'Entering SMUMPS ', & trim(adjustl(id%VERSION_NUMBER)), & trim(FROM_C_INTERFACE_STRING), & ' driver with JOB, N, NELT =', JOB,id%N,id%NELT ENDIF C MPI and OpenMP information !$ IF (.TRUE.) THEN !$ WRITE(MPG, '(A,I6,A,I6)') ' executing #MPI = ', !$ & id%NPROCS, ' and #OMP = ', NOMP !$ IF ( NOMPMIN .NE. NOMPMAX ) THEN !$ WRITE(MPG, '(A,I4,A,I4,A)') !$ & ' WARNING detected: different number of threads (max ', !$ & NOMPMAX, ', min ', NOMPMIN, ')' !$ END IF !$ ELSE WRITE(MPG, '(A,I6,A)') ' executing #MPI = ', & id%NPROCS, ', without OMP' !$ ENDIF IF (JOB.GE.1 .AND. JOB.LE.6) THEN WRITE(MPG, '(A)') ENDIF ENDIF END IF C C---------------------------------------------------------------- C C JOB = -1 : START INITIALIZATION PHASE C (NEW INSTANCE) C C JOB = -2 : TERMINATE AN INSTANCE C---------------------------------------------------------------- C IF ( JOB .EQ. -1 ) THEN C C ------------------------------------------ C Check that we have called (JOB=-2), ie C that the previous JOB is not 1 2 or 3, C before calling the initialization routine. C -------------------------------------------- id%INFO(1)=0 id%INFO(2)=0 OLDJOB = id%KEEP( 40 ) + 456789 IF ( OLDJOB .EQ. 1 .OR. & OLDJOB .EQ. 2 .OR. & OLDJOB .EQ. 3 ) THEN IF ( id%N > 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---------------------------------------------------------------- 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----------------------------------------------------------------------- C TIMINGS IF (id%MYID .eq. MASTER) THEN id%DKEEP(70)=0.0E0 CALL MUMPS_SECDEB(TIMETOTAL) END IF OLDJOB = id%KEEP( 40 ) + 456789 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 IS1 :allocated on the master now, will be allocated on C the slaves later 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 IF (associated(id%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) ENDIF C ------------------------------------------- C Allocate array IS1 for analysis of size: C - assembled entry: 10 * N or 11 * N C depending on max-trans C - element entry: 7 * N + 3 * NELT + 3 C max-trans not allowed C ------------------------------------------- IF ( id%ICNTL(5) .NE. 1 ) THEN ! assembled matrix IF ( id%KEEP(50) .NE. 1 & .AND. ( & (id%ICNTL(6) .NE. 0 .AND. id%ICNTL(7) .NE.1) & .OR. & id%ICNTL(12) .NE. 1) ) THEN id%MAXIS1 = 7 * id%N ELSE id%MAXIS1 = 6 * id%N END IF ELSE id%MAXIS1 = 6 * id%N ENDIF ALLOCATE( id%IS1(id%MAXIS1), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%MAXIS1 IF ( LPOK ) WRITE(LP,'(A)') & ' Problem in allocating work array for analysis' GO TO 100 END IF C C ---------------------- C Allocate PROCNODE(1:N) C ---------------------- IF ( associated( id%PROCNODE ) ) & DEALLOCATE( id%PROCNODE ) ALLOCATE( id%PROCNODE(id%N), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%N IF ( LPOK ) WRITE(LP,'(A)') & 'Problem in allocating work array PROCNODE' GOTO 100 END IF id%PROCNODE(1:id%N) = 0 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. 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 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 ------------------------------------------- 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 CALL SMUMPS_ANA_DRIVER( id ) C Save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ELSE id%INFOG(33)=id%ICNTL(8) ENDIF 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 (id%MYID .eq. MASTER.AND.id%KEEP(492).EQ.0) THEN C No front to be selected for LR id%KEEP(486) = 0 IF (PROKG) & write(MPG,'(A)') " Low rank reset off since no front selected " 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), & id%SIZE_SCHUR*id%SIZE_SCHUR) 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( id%KEEP(52) .EQ. -2 .AND. id%ICNTL(8) .NE. -2 .AND. & id%ICNTL(8).NE. 77 ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** scaling already computed during analysis' WRITE(MPG,'(A)') & ' ** keeping the scaling from the analysis' ENDIF ENDIF IF (id%KEEP(52) .NE. -2) THEN 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 IF ( id%KEEP( 19 ) .ne. 0 .and. id%KEEP( 52 ).ne. 0 ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') ' ** (incompatibility with null space)' END IF id%KEEP(52) = 0 END IF 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 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) id%INFO(1)=-13 ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 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) id%INFO(1)=-13 IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 IF ( id%INFO(1) .eq. -13 ) THEN 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) 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), & id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) 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)) 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 (associated(id%IS1)) THEN DEALLOCATE(id%IS1) NULLIFY(id%IS1) ENDIF IF (associated(id%PROCNODE)) THEN DEALLOCATE(id%PROCNODE) NULLIFY(id%PROCNODE) ENDIF #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(TIMEG) ENDIF 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 = 40 INTEGER :: INFO(40) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(40) 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 .and. INFO(2) .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 SUBROUTINE SMUMPS_PRINT_ICNTL(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 INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL 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) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 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,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) 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) WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) CASE(5); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(6); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13),ICNTL(18),ICNTL(19),ICNTL(22) 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) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 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 =',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 ( 0= off, else=on) =',I10/ & 'ICNTL(20) Dense (0) or sparse (1) 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) Dense (0) or sparse (1) 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 & (size(idRHS)<(idNRHS*idLRHS-idLRHS+idN)) & 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.1.2/src/zfac_distrib_ELT.F0000664000175000017500000004733613164366265017022 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 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)) ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF 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 ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC)=ZERO ENDDO ENDIF 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 ARROW_ROOT = ARROW_ROOT + 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)==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) 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 ) ARROW_ROOT = ARROW_ROOT + NB_REC 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 (KEEP(38).ne.0) THEN DEALLOCATE(ELROOTPOS8) 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.1.2/src/ctools.F0000664000175000017500000007633413164366264015155 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 LOGICAL MOVEPTRAST LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR 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 IF (LDLT.EQ.0) THEN SIZECB = int(LCONT,8) * int(LCONT,8) ELSE SIZECB = int(NROW,8) * int(LCONT,8) ENDIF END IF CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZECB ) IF ((SIZECB.EQ.0_8).AND.(KEEP(201).EQ.0)) THEN GOTO 500 ENDIF IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL CMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) 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 ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF(KEEP(201).EQ.0)THEN PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB ELSE PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) - & SIZECB - SIZELU ENDIF MOVEPTRAST = .TRUE. IF(KEEP(201).EQ.0)THEN PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB ELSE PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB & - SIZELU ENDIF ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF(KEEP(201).EQ.0)THEN PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3))-SIZECB ELSE PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZECB-SIZELU ENDIF ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF(KEEP(201).EQ.0)THEN PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB ELSE PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB & - SIZELU ENDIF END IF IPS = IPS + IPSIZE END DO IF ((SIZECB .NE. 0_8).OR.(KEEP(201).NE.0)) THEN IF (KEEP(201).NE.0) THEN DO I=IAPOS, POSFAC - SIZECB - SIZELU - 1_8 A( I ) = A( I + SIZECB + SIZELU) END DO ELSE DO I=IAPOS + SIZELU, POSFAC - SIZECB - 1_8 A( I ) = A( I + SIZECB ) END DO ENDIF END IF ENDIF IF (KEEP(201).NE.0) THEN POSFAC = POSFAC - (SIZECB+SIZELU) LRLU = LRLU + (SIZECB+SIZELU) LRLUS = LRLUS + (SIZECB+SIZELU) - SIZE_INPLACE KEEP8(70) = KEEP8(70) + (SIZECB+SIZELU) - SIZE_INPLACE KEEP8(71) = KEEP8(71) + (SIZECB+SIZELU) - SIZE_INPLACE ELSE POSFAC = POSFAC - SIZECB LRLU = LRLU + SIZECB LRLUS = LRLUS + SIZECB - SIZE_INPLACE KEEP8(70) = KEEP8(70) + SIZECB - SIZE_INPLACE KEEP8(71) = KEEP8(71) + SIZECB - SIZE_INPLACE IF (LRCOMPRESS_PANEL) THEN KEEP8(71) = KEEP8(71) + SIZELU ENDIF ENDIF 500 CONTINUE CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE,KEEP,KEEP8,LRLUS) 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, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) USE CMUMPS_OOC USE CMUMPS_LOAD 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(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) :: LAFAC, 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) 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 )) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS_CB+XXR)) 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_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRAST(STEP(ISON))), LAFAC, 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) 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 ) 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(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), 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+XXI)=LREQI CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXS)=-9999 IW(POSI+XXS+1:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXLR) = LRSTATUS 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 POSALOC = POSA DO I = 1, NROW_L OLDPOS = PTRAST( STEP(ISON)) + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = 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 KEEP8(10) = KEEP8(10) + int(NCOL_L,8) * int(NROW_L,8) 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 KEEP8(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + LREQA 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 & ) 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 ISTCHK = PTRIST(STEP(ISON)) CALL CMUMPS_FREE_BLOCK_CB(.FALSE.,MYID, N, ISTCHK, & PTRAST(STEP(ISON)), & 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_MAX_MEM( KEEP,KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, PERLU_ON, & MEMORY_BYTES ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON INTEGER, INTENT(IN) :: OOC_STRAT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID, N, NELT, NSLAVES, LNA INTEGER(8) :: NA_ELT8, NNZ8 INTEGER(8), INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT) :: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL, MAXS_MIN 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 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 ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MAXS_MIN = KEEP8(14) ELSE MAXS_MIN = KEEP8(12) ENDIF IF ( .NOT. EFF ) THEN IF ( KEEP8(24).EQ.0_8 ) THEN NB_REAL = NB_REAL + MAXS_MIN + & int(PERLU,8)*(MAXS_MIN / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + KEEP8(67) 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 CMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) CMUMPS_LBUFR_BYTES8 = max( CMUMPS_LBUFR_BYTES8, & 100000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF 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(43))-100,8)) NB_BYTES = NB_BYTES + CMUMPS_LBUFR_BYTES8 CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 43 ) * KEEP( 35 )), 8 ) 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 CMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(CMUMPS_LBUF_INT,8) IF ( EFF ) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int(KEEP(225),8) ELSE NB_INT = NB_INT + int(KEEP(15),8) ENDIF ELSE 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(486).NE.0) THEN NB_INT = NB_INT + N8 NB_REAL = NB_REAL + & int(KEEP(127),8)*int(KEEP(488),8) ENDIF END IF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = int( MEMORY_BYTES / 1000000_8 ) + 1 RETURN END SUBROUTINE CMUMPS_MAX_MEM 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_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,COMPRESSCB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL COMPRESSCB COMPLEX A(ASIZE) REAL M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW REAL ZERO,TMP PARAMETER (ZERO=0.0E0) M_ARRAY(1:NMAX) = ZERO APOS = 0_8 IF (COMPRESSCB) 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 (COMPRESSCB) 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) IF (associated(id%IS1)) NB_INT=NB_INT+size(id%IS1) 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%BUFR)) NB_INT=NB_INT+size(id%BUFR) 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%PROCNODE)) NB_INT=NB_INT+size(id%PROCNODE) IF (associated(id%INTARR)) NB_INT=NB_INT+size(id%INTARR) 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_BEFORE_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_BEFORE_L0_OMP) IF (associated(id%IPOOL_AFTER_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_AFTER_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+size(id%DBLARR) IF (associated(id%RHSCOMP)) NB_CMPLX=NB_CMPLX+size(id%RHSCOMP) 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 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_SIZE ) USE CMUMPS_STATIC_PTR_M INTEGER, INTENT(IN) :: THE_SIZE COMPLEX, INTENT(IN) :: THE_ADDRESS(THE_SIZE) CALL CMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE)) RETURN END SUBROUTINE CMUMPS_SET_TMP_PTR MUMPS_5.1.2/src/mumps_thread.c0000664000175000017500000000056713164366240016364 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html * */ MUMPS_5.1.2/src/cfac_process_contrib_type1.F0000664000175000017500000001050113164366264021126 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) 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(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 COMPRESSCB 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) COMPRESSCB = (FLCONT.LT.0) IF (COMPRESSCB) 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) IF (IPTRLU.LT.0_8) WRITE(*,*) 'before alloc_cb:IPTRLU = ',IPTRLU CALL CMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, IFLAG, IERROR & ) IF (IPTRLU.LT.0_8) WRITE(*,*) 'after alloc_cb:IPTRLU = ',IPTRLU IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (COMPRESSCB) 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 (COMPRESSCB) 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 IF ( LREQCB .ne. 0_8 ) THEN IPOS_NODE = PAMASTER(STEP(FINODE))-1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + 1_8 + ISHIFT_PACKET), & SIZE_PACKET, MPI_COMPLEX, COMM, IERR) END IF 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.1.2/src/dmumps_ooc_buffer.F0000664000175000017500000004252413164366264017342 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC_BUF_PANEL' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC_BUF_PANEL' 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) & WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC_BUF_PANEL' 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.1.2/src/cfac_process_bf.F0000664000175000017500000000071313164366264016737 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE CMUMPS_PROCESS_BF_RETURN MUMPS_5.1.2/src/sini_defaults.F0000664000175000017500000013412113164366266016472 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 SIZE_INT, SIZE_REAL_OR_DOUBLE ! Type must match MUMPS_INT 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(40), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(40), INFOG(40) 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) has default value 0.01 and is used for C threshold pivoting. Values greater than 1.0 C are treated as 1.0, and less than zero as zero. 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 only used combined with null pivot row C detection (ICNTL(24) .eq. 1) and to Rank-Revealing (RR) option. C It must be set to the absolute threshold for numerical pivoting. 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 row/column C is smaller than a threshold. Let MACHEPS be the machine precision and C ||.|| be the infinite norm. C The computed threshold value for postponing pivots in case of RR on root C is stored in "SEUIL" and then "SEUIL_LDLT_NIV2" C which are identical in current version. C This absolute threshold value is stored in DKEEP(9). C C The absolute value to detect a null pivot (when ICNTL(24) .NE.0) C is stored in DKEEP(1) and must be smaller than C SEUIL when combined with RR on root. C C IF (ICNTL(16).NE.0) THEN C RR on root is active C IF (CNTL3 .LT. ZERO) THEN C SEUIL = abs(CNTL(3)) C ELSE IF (CNTL3 .GT. ZERO) THEN C SEUIL = CNTL3*ANORMINF C ELSE ! (CNTL(3) .EQ. ZERO) THEN C SEUIL = N*EPS*ANORMINF ! standard articles C ENDIF C IF (ICNTL(24).NE.0) THEN C null pivot detection C IF (CNTL(6).GT.0.AND.CNTL(6).LT.1) THEN C we want DKEEP(1) < SEUIL C DKEEP(1) = SEUIL*CNTL(6) ! ideally it could be SEUIL*CNTL(6) C ELSE C DKEEP(1) = SEUIL* 0.01E0 C ENDIF C ENDIF C C ELSE (ONLY NULL PIVOT detection is active) C we keep stratgy used in MUMPS_4.10 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 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 the row/column (except the pivot) is set to zero C and the pivot is set to 1 C Default is 0. C Note that in the symmetric parallel case, some elements of the column C are not available on the local processor and cannot be set to 0 easily. C In such cases, in the current version, C -the corresponding pivot is first set C to a large value instead of 1, even when CNTL(5) < 0. C -Updating of the off diag block is done with this large C value C -diagonal value is then reset to zero C C CNTL(6) expresses the ratio between C absolute criterion for null pivots and absolute criterion C for posponing pivots before partial pivoting analysis of pivots. C Typically C let SEUIL = F(CNTL(3)), and 0 < CNTL(6) < 1 C SEUIL is stored in DKEEP(9) C if ||Pivot row|| < SEUIL*CNTL(6) then C null pivot row detected (correct only if LDLT C for LU pivot_col must be checked too) C else if || Pivot_Row || < SEUIL then C pospone pivot C else C partial threshold pivoting C endif 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 default = 0 C else C if distributed matrix entry then C default = 7 C else C if (mc64 called or mc77 based matching) then C default=-2 and ordering is computed during analysis C else C default = 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 define 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 set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is automatically C set to 5 and ICNTL(6) is set to -2 (we need the scaling factors C 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 Authorizing extra root spliting C during analysis might be interesting C to further split the root node C (combined for example with C null pivot detection option ICNTL(24)=1 OR ICNTL(16)) 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 (or 30, or 5 depending on NSLAVES, C SYM,...) and is the value for memory relaxation C so called "PERLU" in the following. 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). 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, k=1,NRHS is C considered to be the solution corresponding to the Schur C variables. It is injected in SMUMPS, that computes the solution C on the "internal" problem during the backward 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 performed by the solver. C Default value is -24. 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 C ICNTL(35) : Block low rank (BLR) factorization C Default value is 0 C 0 = BLR is not activated C 1 = BLR activated with grouping based C on inherited clustering done during analysis C Other values are treated as zero C Note that this functionality is currently incompatible with elemental matrices C (ICNTL(5) = 1) and with forward elimination during factorization (ICNTL(32) = 1). C C ICNTL(38) not used in this version C C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 40 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 arry 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. 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 Note that it does not include null pivots C that might have been C further detected on the root (ICNTL(16).NE.0). 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 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=========================== 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:40) = 0 INFOG(1:40) = 0 ICNTL(1:40) = 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 CNTL(6) = -1.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 IF (NSLAVES .GT. 4) THEN ICNTL(14) = 30 ELSE ICNTL(14) = 20 END IF C Minimum size of the null space ICNTL(15) = 0 C Do not look for rank/null space basis ICNTL(16) = 0 C Max size of null space ICNTL(17) = 0 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 --------- Non documented ICNTL options C Old or new symbolic factorization ICNTL(39) = 1 ICNTL(40) = 0 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 C KEEP(11) = 2147483646 KEEP(11) = huge(KEEP(11)) KEEP(24) = 18 KEEP(68) = 0 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 500 KEEP(58) = 250 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 KEEP(17) = 0 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 !write(6,*) ' TEMPORARY new splitting active, K79=', KEEP(79) 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(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 #if ! defined(NO_XXNBPR) KEEP(121)=-999999 #endif KEEP(122)=15 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)=50 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 DKEEP(10) = 1000.0E0 ! > 0 : GAP IF(NSLAVES.LE.8)THEN KEEP(238)=12 ELSE KEEP(238)=7 ENDIF KEEP(234)= 1 KEEP(235)=-1 DKEEP(3)=-5.0E0 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) = 0 KEEP(266) = 0 KEEP(267) = 0 KEEP(350) = 1 KEEP(351) = 0 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 KEEP(468) = 3 KEEP(469) = 1 KEEP(470) = 1 KEEP(471) = -1 KEEP(480) = 0 KEEP(479) = 1 KEEP(478) = 0 KEEP(474) = 0 KEEP(481) = 0 KEEP(482) = 0 KEEP(472) = 1 KEEP(473) = 0 KEEP(475) = 0 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 50 KEEP(484) = 50 KEEP(485) = 1 ! (1 promote factors) 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(489) = 0 KEEP(490) = 128 KEEP(491) = 1000 KEEP(492) = 1 KEEP(82) = 30 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 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%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 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.1.2/src/smumps_f77.F0000664000175000017500000003265713164366262015657 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, 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, & 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, & IRHS_SPARSE, IRHS_SPARSEhere, & IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, & NZ_RHS, LSOL_loc & , & SCHUR_MLOC, & SCHUR_NLOC, & SCHUR_LLD, & MBLOCK, & NBLOCK, & NPROW, & NPCOL, & & OOC_TMPDIR, & OOC_PREFIX, & WRITE_PROBLEM, & TMPDIRLEN, & PREFIXLEN, & WRITE_PROBLEMLEN & & ) 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 JOB, SYM, PAR, COMM_F77, N, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(40), INFO(40), INFOG(40), 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(*), ISOL_loc(*) 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(*) 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 IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, PERM_INhere, WK_USERhere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, IRHS_PTRhere, IRHS_SPARSEhere, ISOL_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 A_ELT_SIZE, I, Np, IERR INTEGER(8) :: 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 mumps_par_array(INSTANCE_NUMBER)%PTR%KEEP(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%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:40)=ICNTL(1:40) 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%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_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 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:A_ELT_SIZE) END IF 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:NRHS*LRHS) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:NRHS*LREDRHS) 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:LSOL_loc*NRHS) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_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 CALL SMUMPS( mumps_par ) INFO(1:40)=mumps_par%INFO(1:40) INFOG(1:40)=mumps_par%INFOG(1:40) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:40) = mumps_par%ICNTL(1:40) 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) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N 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 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.1.2/src/zbcast_int.F0000664000175000017500000000276113164366265016004 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/dfac_front_type2_aux.F0000664000175000017500000006633113164366264017753 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NNEG, & 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) 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, NNEG INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR INTEGER, intent(inout) :: Inextpiv 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 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 K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDAFS = NASS LDAFS8 = int(LDAFS,8) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) 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 IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEG = NNEG+1 ENDIF ELSE IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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 APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG (IPIV) = abs(A(POSPV1)) 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) NNEG = NNEG+1 IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) 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 = max(abs(A(J1)),AMAX) 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)),RMAX_NOSLAVE) J1 = J1 + LDAFS8 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 KEEP(109) = KEEP(109)+1 PIVNUL_LIST(KEEP(109)) = -1 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 + LDAFS8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO DO J=1,NASS - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDAFS8 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) NNEG = NNEG+1 IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) 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 J1 = POSPV1 + LDAFS8 DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(J1)),RMAX_NOSLAVE) ENDIF J1 = J1 + LDAFS8 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 IF (KEEP(258).NE.0) THEN CALL DMUMPS_UPDATEDETER(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(105) = KEEP(105)+1 IF(DETPIV .LT. RZERO) THEN NNEG = NNEG+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEG = NNEG+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 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(201).EQ.1.AND.KEEP(50).NE.1) 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) 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 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(NASS - NPIV_NEW,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,NBPROCFILS,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, SEND_LR, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_TYPE IMPLICIT NONE INCLUDE 'dmumps_root.h' 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(40) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), & 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)), & NBPROCFILS(KEEP(28)), 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) :: SEND_LR 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 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 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, & SEND_LR, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/ssol_c.F0000664000175000017500000026255413164366263015134 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, PTR_RHS_ROOT, LPTR_RHS_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 , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS & ) USE SMUMPS_OOC USE MUMPS_SOL_ES IMPLICIT NONE INCLUDE 'smumps_root.h' #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(40),INFO(40), KEEP(500) 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)) #if defined(RHSCOMP_BYROWS) REAL :: RHSCOMP(NRHS, LRHSCOMP) #else REAL :: RHSCOMP(LRHSCOMP,NRHS) #endif 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) :: LPTR_RHS_ROOT REAL PTR_RHS_ROOT(LPTR_RHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,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 INTEGER IZERO 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 PARAMETER (IZERO = 0 ) REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mumps_headers.h' 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) :: LPTR_RHS_BOUNDS INTEGER, intent(inout) :: PTR_RHS_BOUNDS (LPTR_RHS_BOUNDS) REAL, intent(inout) :: DKEEP(230) 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, DIMENSION(:), ALLOCATABLE :: prun_NA INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP, INODE_PRINC LOGICAL AM1, DO_PRUN LOGICAL Exploit_Sparsity LOGICAL DO_NBSPARSE_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 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 = KEEP(28)+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 IF (.not. allocated(Pruned_SONS)) 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 END IF IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (.not. allocated(TO_PROCESS)) THEN SIZE_TO_PROCESS = KEEP(28) 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 END IF TO_PROCESS(:) = .TRUE. ENDIF 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 MUMPS_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 MUMPS_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 MUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), 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 MUMPS_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), & PTR_RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL MUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, PTR_RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, & 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 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 SMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE, & FROM_PP & ) ELSE ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), & STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves+nb_prun_roots+2 END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 prun_NA(1) = nb_prun_leaves prun_NA(2) = nb_prun_roots DO I = 1, nb_prun_leaves prun_NA(I+2) = Pruned_Leaves(I) ENDDO DO I = 1, nb_prun_roots prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) ENDDO DEALLOCATE(Pruned_List) DEALLOCATE(Pruned_Leaves) IF (AM1) THEN DEALLOCATE(Pruned_Roots) END IF IF ((Exploit_Sparsity).AND.(nb_prun_roots.EQ.NA(2))) THEN DEALLOCATE(Pruned_Roots) IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) SWITCH_OFF_ES = .TRUE. ENDIF CALL SMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & Pruned_SONS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) DEALLOCATE(prun_NA) 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. 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 MUMPS_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 MUMPS_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 MUMPS_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 PTR_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, & PTR_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 (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF 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 ( AM1 ) THEN CALL MUMPS_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 MUMPS_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 MUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL MUMPS_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), & PTR_RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL MUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, PTR_RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, & 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 = IZERO 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 PTR_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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,II) = ZERO #else RHSCOMP(II, K) = ZERO #endif ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN ) THEN SIZE_TO_PROCESS = 1 IF (allocated(TO_PROCESS)) DEALLOCATE(TO_PROCESS) ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) TO_PROCESS(:) = .TRUE. 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, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, DKEEP, & PTR_RHS_ROOT, LPTR_RHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE_BWD, & FROM_PP & ) ELSE ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), & STAT=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of prun_na' CALL MUMPS_ABORT() END IF prun_NA(1) = nb_prun_leaves prun_NA(2) = nb_prun_roots DO I = 1, nb_prun_leaves prun_NA(I+2) = Pruned_Leaves(I) ENDDO DO I = 1, nb_prun_roots prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) ENDDO 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, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & PTR_RHS_ROOT, LPTR_RHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP) ENDIF #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 #if defined(RHSCOMP_BYROWS) K = min0(10,size(RHSCOMP,2)) IF (LDIAG.EQ.4) K = size(RHSCOMP,2) WRITE (MP,99992) IF (size(RHSCOMP,2).GT.0) & WRITE (MP,99993) (RHSCOMP(1,I),I=1,K) IF (size(RHSCOMP,2).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSCOMP(2,I),I=1,K) #else K = min0(10,size(RHSCOMP,1)) IF (LDIAG.EQ.4) K = size(RHSCOMP,1) 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(prun_NA)) DEALLOCATE (prun_NA) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (first column)'/(1X,1P,5E14.6)) 99994 FORMAT (' RHS (2 nd column)'/(1X,1P,5E14.6)) 99992 FORMAT (//' LEAVING SOLVE (MPI41C) 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) #if defined(RHSCOMP_BYROWS) REAL, intent(in) :: RHSCOMP(NCOL_RHSCOMP, LRHSCOMP) #else REAL, intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) #endif 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 PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP INTEGER SK38, SK20 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 MUMPS_PROCNODE 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 = N/2 !$ 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)) !$ 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) # else RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) # endif 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) # else RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) # endif 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 = N/2 !$ 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)) !$ 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = RHSCOMP(J,IPOSINRHSCOMP) # else RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) # endif 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = RHSCOMP(J,IPOSINRHSCOMP) # else RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) # endif 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 defined(RHSCOMP_BYROWS) IF (LCWORK .LT. NRHS) THEN WRITE(*,*) MYID, & ": Internal error 2 in SMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF #else 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 #endif IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247))) 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 (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) THEN IPOS = PTRIST(ISTEP)+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV 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 (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) #if defined(RHSCOMP_BYROWS) DO I=1,NPIV II=IROWLIST(I) CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NRHS, MPI_REAL, & COMM, IERR) IF (LSCAL.AND.KEEP(242).EQ.0) THEN DO J=1,NRHS JCOL_RHS = J+JBEG_RHS-1 RHS(II,JCOL_RHS) = CWORK(J)*SCALING(II) ENDDO ELSE IF ((.NOT. LSCAL).AND.(KEEP(242).EQ.0)) THEN DO J=1,NRHS JCOL_RHS = J+JBEG_RHS-1 RHS(II,JCOL_RHS) = CWORK(J) ENDDO ELSE IF (LSCAL.AND.KEEP(242).NE.0) THEN DO J=1,NRHS JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) RHS(II,JCOL_RHS) = CWORK(J)*SCALING(II) ENDDO ELSE DO J=1,NRHS JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) RHS(II,JCOL_RHS) = CWORK(J) ENDDO ENDIF ENDDO #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 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 #endif 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 defined(RHSCOMP_BYROWS) IF (KEEP(242).EQ.0) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) IF (LSCAL) THEN DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) ENDDO ELSE DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(J,IPOSINRHSCOMP) ENDDO ENDIF ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(J,IPOSINRHSCOMP) IF (LSCAL) THEN RHS(I,PERM_RHS(J+JBEG_RHS-1)) = RHS(I,PERM_RHS(J+JBEG_RHS-1))*SCALING(I) ENDIF ENDDO ENDDO ENDIF #else 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) 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) DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF 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)) #if defined(RHSCOMP_BYROWS) DO II=1,NPIV DO J=1, NRHS CWORK(J) = RHSCOMP(J,IPOSINRHSCOMP+II-1) ENDDO CALL MPI_PACK(CWORK(1), NRHS, & MPI_REAL, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO #else DO J=1,NRHS CALL MPI_PACK(RHSCOMP(IPOSINRHSCOMP,J), NPIV, & MPI_REAL, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO #endif 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 #if defined(RHSCOMP_BYROWS) REAL, intent(in) :: RHSCOMP (NRHSCOMP_COL,LRHSCOMP) #else REAL, intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL) #endif 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 #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)= & RHSCOMP(K,IPOSINRHSCOMP)*SCALING(I) #else RHS_SPARSE_COPY(IZ)= & RHSCOMP(IPOSINRHSCOMP,K)*SCALING(I) #endif ELSE #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)=RHSCOMP(K,IPOSINRHSCOMP) #else RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) #endif 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 #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)=RHSCOMP(K,IPOSINRHSCOMP) #else RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) #endif 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) 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 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 INTEGER SK38,SK20 INCLUDE 'mumps_headers.h' IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 DO JJ=J1,J1+NPIV-1 K=K+1 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 ) # if defined(RHSCOMP_BYROWS) REAL RHSCOMP( NBRHS_EFF, LRHSCOMP ) # else REAL RHSCOMP( LRHSCOMP, NBRHS_EFF ) # endif 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), & SLAVEF)) 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 ((KEEP(242) .EQ. 0).AND.(KEEP(350).EQ.0)) THEN KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 IPOSINRHSCOMP = POSINRHSCOMP(IW(JJ)) IF (NB_RHSSKIPPED.GT.0) THEN SOL_LOC(KLOC, BEG_RHS:JEMPTY) = ZERO ENDIF IF (LSCAL) THEN # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(1:NBRHS_EFF,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,1:NBRHS_EFF) # endif ELSE # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JEMPTY+1:JEND) = & RHSCOMP(1:NBRHS_EFF,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JEMPTY+1:JEND) = & RHSCOMP(IPOSINRHSCOMP,1:NBRHS_EFF) # endif ENDIF ENDDO ELSE 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+1) .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 # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(JCOL-JEMPTY,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) # endif ELSE # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(JCOL-JEMPTY,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) # endif ENDIF ENDDO ENDDO !$OMP END PARALLEL DO ENDIF 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(40), INFO(40) REAL, intent(in) :: RHS (LRHS, NCOL_RHS) #if defined(RHSCOMP_BYROWS) REAL, intent(out) :: RHSCOMP(NCOL_RHSCOMP, LRHSCOMP) #else REAL, intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) #endif 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 SK38, SK20 !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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 #if defined(RHSCOMP_BYROWS) DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP DO K=1, NCOL_RHSCOMP RHSCOMP (K, I) = ZERO ENDDO ENDDO #else DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO #endif 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& FIRSTPRIVATE(BUF_EFFSIZE) 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 #if defined(RHSCOMP_BYROWS) DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP DO K=1, NCOL_RHSCOMP RHSCOMP (K, I) = ZERO ENDDO ENDDO #else DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO #endif ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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)) END IF 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 defined(RHSCOMP_BYROWS) DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSCOMP( K, INDX+JJ-J1 ) = RHS( J, K ) ENDDO ENDDO #else 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(J1,NPIV,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 #endif 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& FIRSTPRIVATE(BUF_EFFSIZE) IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) #if defined(RHSCOMP_BYROWS) RHSCOMP( K, INDX ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE ) #else RHSCOMP( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) #endif 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 #if defined(RHSCOMP_BYROWS) RHSCOMP( K, INDX ) = BUF_RHS( K, I ) #else RHSCOMP( INDX, K ) = BUF_RHS( K, I ) #endif 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 SK38, SK20, IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 SK38, SK20, 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 IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 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.1.2/src/sini_driver.F0000664000175000017500000001747513164366266016172 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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" 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 C Reception buffer initialized to zero NULLIFY(id%BUFR) C id%MAXIS1 = 0 C C id%INST_Number = -1 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) id%LSOL_loc=0 NULLIFY(id%SOL_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%IS1) NULLIFY(id%STEP) 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%PROCNODE) 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) 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_BEFORE_L0_OMP) NULLIFY(id%IPOOL_AFTER_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) 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.1.2/src/csol_root_parallel.F0000664000175000017500000000723213164366264017520 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), 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.1.2/src/dini_defaults.F0000664000175000017500000013431213164366266016455 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 SIZE_INT, SIZE_REAL_OR_DOUBLE ! Type must match MUMPS_INT 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(40), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(40), INFOG(40) 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) has default value 0.01 and is used for C threshold pivoting. Values greater than 1.0 C are treated as 1.0, and less than zero as zero. 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 only used combined with null pivot row C detection (ICNTL(24) .eq. 1) and to Rank-Revealing (RR) option. C It must be set to the absolute threshold for numerical pivoting. 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 row/column C is smaller than a threshold. Let MACHEPS be the machine precision and C ||.|| be the infinite norm. C The computed threshold value for postponing pivots in case of RR on root C is stored in "SEUIL" and then "SEUIL_LDLT_NIV2" C which are identical in current version. C This absolute threshold value is stored in DKEEP(9). C C The absolute value to detect a null pivot (when ICNTL(24) .NE.0) C is stored in DKEEP(1) and must be smaller than C SEUIL when combined with RR on root. C C IF (ICNTL(16).NE.0) THEN C RR on root is active C IF (CNTL3 .LT. ZERO) THEN C SEUIL = abs(CNTL(3)) C ELSE IF (CNTL3 .GT. ZERO) THEN C SEUIL = CNTL3*ANORMINF C ELSE ! (CNTL(3) .EQ. ZERO) THEN C SEUIL = N*EPS*ANORMINF ! standard articles C ENDIF C IF (ICNTL(24).NE.0) THEN C null pivot detection C IF (CNTL(6).GT.0.AND.CNTL(6).LT.1) THEN C we want DKEEP(1) < SEUIL C DKEEP(1) = SEUIL*CNTL(6) ! ideally it could be SEUIL*CNTL(6) C ELSE C DKEEP(1) = SEUIL* 0.01D0 C ENDIF C ENDIF C C ELSE (ONLY NULL PIVOT detection is active) C we keep stratgy used in MUMPS_4.10 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 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 the row/column (except the pivot) is set to zero C and the pivot is set to 1 C Default is 0. C Note that in the symmetric parallel case, some elements of the column C are not available on the local processor and cannot be set to 0 easily. C In such cases, in the current version, C -the corresponding pivot is first set C to a large value instead of 1, even when CNTL(5) < 0. C -Updating of the off diag block is done with this large C value C -diagonal value is then reset to zero C C CNTL(6) expresses the ratio between C absolute criterion for null pivots and absolute criterion C for posponing pivots before partial pivoting analysis of pivots. C Typically C let SEUIL = F(CNTL(3)), and 0 < CNTL(6) < 1 C SEUIL is stored in DKEEP(9) C if ||Pivot row|| < SEUIL*CNTL(6) then C null pivot row detected (correct only if LDLT C for LU pivot_col must be checked too) C else if || Pivot_Row || < SEUIL then C pospone pivot C else C partial threshold pivoting C endif 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 default = 0 C else C if distributed matrix entry then C default = 7 C else C if (mc64 called or mc77 based matching) then C default=-2 and ordering is computed during analysis C else C default = 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 define 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 set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is automatically C set to 5 and ICNTL(6) is set to -2 (we need the scaling factors C 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 Authorizing extra root spliting C during analysis might be interesting C to further split the root node C (combined for example with C null pivot detection option ICNTL(24)=1 OR ICNTL(16)) 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 (or 30, or 5 depending on NSLAVES, C SYM,...) and is the value for memory relaxation C so called "PERLU" in the following. 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). 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, k=1,NRHS is C considered to be the solution corresponding to the Schur C variables. It is injected in DMUMPS, that computes the solution C on the "internal" problem during the backward 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 performed by the solver. C Default value is -24. 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 C ICNTL(35) : Block low rank (BLR) factorization C Default value is 0 C 0 = BLR is not activated C 1 = BLR activated with grouping based C on inherited clustering done during analysis C Other values are treated as zero C Note that this functionality is currently incompatible with elemental matrices C (ICNTL(5) = 1) and with forward elimination during factorization (ICNTL(32) = 1). C C ICNTL(38) not used in this version C C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 40 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 arry 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. 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 Note that it does not include null pivots C that might have been C further detected on the root (ICNTL(16).NE.0). 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 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=========================== 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:40) = 0 INFOG(1:40) = 0 ICNTL(1:40) = 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 CNTL(6) = -1.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 IF (NSLAVES .GT. 4) THEN ICNTL(14) = 30 ELSE ICNTL(14) = 20 END IF C Minimum size of the null space ICNTL(15) = 0 C Do not look for rank/null space basis ICNTL(16) = 0 C Max size of null space ICNTL(17) = 0 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 --------- Non documented ICNTL options C Old or new symbolic factorization ICNTL(39) = 1 ICNTL(40) = 0 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 C KEEP(11) = 2147483646 KEEP(11) = huge(KEEP(11)) KEEP(24) = 18 KEEP(68) = 0 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 500 KEEP(58) = 250 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 KEEP(17) = 0 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 !write(6,*) ' TEMPORARY new splitting active, K79=', KEEP(79) 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(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 #if ! defined(NO_XXNBPR) KEEP(121)=-999999 #endif KEEP(122)=150 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)=50 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 DKEEP(10) = 1000.0D0 ! > 0 : GAP IF(NSLAVES.LE.8)THEN KEEP(238)=12 ELSE KEEP(238)=7 ENDIF KEEP(234)= 1 KEEP(235)=-1 DKEEP(3)=-5.0D0 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) = 0 KEEP(266) = 0 KEEP(267) = 0 KEEP(350) = 1 KEEP(351) = 0 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 KEEP(468) = 3 KEEP(469) = 1 KEEP(470) = 1 KEEP(471) = -1 KEEP(480) = 0 KEEP(479) = 1 KEEP(478) = 0 KEEP(474) = 0 KEEP(481) = 0 KEEP(482) = 0 KEEP(472) = 1 KEEP(473) = 0 KEEP(475) = 0 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 50 KEEP(484) = 50 KEEP(485) = 1 ! (1 promote factors) 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(489) = 0 KEEP(490) = 128 KEEP(491) = 1000 KEEP(492) = 1 KEEP(82) = 30 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 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%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 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.1.2/src/dlr_stats.F0000664000175000017500000012434113164366264015641 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE DMUMPS_LR_STATS USE DMUMPS_LR_TYPE IMPLICIT NONE DOUBLE PRECISION :: ACC_MRY_CB_GAIN, & ACC_MRY_CB_FR, & FRONT_L11_BLR_SAVINGS, & FRONT_U11_BLR_SAVINGS, & FRONT_L21_BLR_SAVINGS, & FRONT_U12_BLR_SAVINGS, & ACC_FR_MRY, & GLOBAL_BLR_SAVINGS, & GLOBAL_MRY_LPRO_COMPR, & GLOBAL_MRY_LTOT_COMPR INTEGER :: CNT_NODES DOUBLE PRECISION :: FLOP_FR_UPDT, & FLOP_LR_UPDT, & FLOP_LR_UPDT_OUT, & FLOP_RMB, & FLOP_FR_TRSM, & FLOP_LR_TRSM, & FLOP_PANEL, & FLOP_TRSM, & FLOP_DEC_ACC, & FLOP_REC_ACC, & FLOP_DEMOTE, & FLOP_CB_DEMOTE, & FLOP_CB_PROMOTE, & LR_FLOP_GAIN DOUBLE PRECISION :: ACC_LR_FLOP_GAIN DOUBLE PRECISION :: ACC_FLOP_FR_FACTO, & ACC_FLOP_LR_FACTO, & ACC_FLOP_FR_TRSM, & ACC_FLOP_LR_TRSM, & ACC_FLOP_FR_UPDT, & ACC_FLOP_LR_UPDT, & ACC_FLOP_LR_UPDT_OUT, & ACC_FLOP_RMB, & ACC_FLOP_DEMOTE, & ACC_FLOP_CB_DEMOTE, & ACC_FLOP_CB_PROMOTE, & ACC_FLOP_TRSM, & ACC_FLOP_DEC_ACC, & ACC_FLOP_REC_ACC, & ACC_FLOP_PANEL, & ACC_FLOP_FRFRONTS, & ACC_FLOP_FR_SOLVE, & ACC_FLOP_LR_SOLVE DOUBLE PRECISION :: FACTOR_PROCESSED_FRACTION INTEGER(KIND=8) :: FACTOR_SIZE DOUBLE PRECISION :: TOTAL_FLOP DOUBLE PRECISION :: BLR_TIME_LRGROUPING DOUBLE PRECISION :: BLR_TIME_SEPGROUPING DOUBLE PRECISION :: BLR_TIME_GETHALO DOUBLE PRECISION :: BLR_TIME_KWAY DOUBLE PRECISION :: BLR_TIME_GNEW DOUBLE PRECISION :: ACC_UPDT_TIME DOUBLE PRECISION :: ACC_RMB_TIME DOUBLE PRECISION :: ACC_UPDT_TIME_OUT DOUBLE PRECISION :: ACC_PROMOTING_TIME DOUBLE PRECISION :: ACC_DEMOTING_TIME DOUBLE PRECISION :: ACC_CB_DEMOTING_TIME DOUBLE PRECISION :: ACC_LR_MODULE_TIME DOUBLE PRECISION :: ACC_TRSM_TIME DOUBLE PRECISION :: ACC_FRPANELS_TIME DOUBLE PRECISION :: ACC_FAC_I_TIME DOUBLE PRECISION :: ACC_FAC_MQ_TIME DOUBLE PRECISION :: ACC_FAC_SQ_TIME DOUBLE PRECISION :: ACC_FRFRONTS_TIME DOUBLE PRECISION :: AVG_ACC_FLOP_LR_FACTO DOUBLE PRECISION :: MIN_ACC_FLOP_LR_FACTO DOUBLE PRECISION :: MAX_ACC_FLOP_LR_FACTO 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 INTEGER, POINTER :: STEP_STATS(:) 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 UPDATE_ALL_TIMES(INODE, LOC_FACTO_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_FACTO_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_FRFRONTS_TIME, LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME ACC_UPDT_TIME = ACC_UPDT_TIME + LOC_FACTO_TIME ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + LOC_PROMOTING_TIME ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + LOC_DEMOTING_TIME ACC_CB_DEMOTING_TIME = ACC_CB_DEMOTING_TIME + & LOC_CB_DEMOTING_TIME ACC_FRPANELS_TIME = ACC_FRPANELS_TIME + LOC_FRPANELS_TIME ACC_FAC_I_TIME = ACC_FAC_I_TIME + LOC_FAC_I_TIME ACC_FAC_MQ_TIME = ACC_FAC_MQ_TIME + LOC_FAC_MQ_TIME ACC_FAC_SQ_TIME = ACC_FAC_SQ_TIME + LOC_FAC_SQ_TIME ACC_FRFRONTS_TIME = ACC_FRFRONTS_TIME + LOC_FRFRONTS_TIME ACC_TRSM_TIME = ACC_TRSM_TIME + LOC_TRSM_TIME ACC_LR_MODULE_TIME = ACC_LR_MODULE_TIME + LOC_LR_MODULE_TIME END SUBROUTINE UPDATE_ALL_TIMES SUBROUTINE UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_CB_DEMOTING_TIME ACC_CB_DEMOTING_TIME = ACC_CB_DEMOTING_TIME + & LOC_CB_DEMOTING_TIME END SUBROUTINE UPDATE_CB_DEMOTING_TIME SUBROUTINE UPDATE_UPDT_TIME(INODE, LOC_UPDT_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_UPDT_TIME ACC_UPDT_TIME = ACC_UPDT_TIME + LOC_UPDT_TIME END SUBROUTINE UPDATE_UPDT_TIME SUBROUTINE UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) DOUBLE PRECISION, INTENT(IN) :: LOC_UPDT_TIME_OUT ACC_UPDT_TIME_OUT = ACC_UPDT_TIME_OUT + LOC_UPDT_TIME_OUT END SUBROUTINE UPDATE_UPDT_TIME_OUT SUBROUTINE UPDATE_RMB_TIME(LOC_RMB_TIME) DOUBLE PRECISION, INTENT(IN) :: LOC_RMB_TIME ACC_RMB_TIME = ACC_RMB_TIME + LOC_RMB_TIME END SUBROUTINE UPDATE_RMB_TIME SUBROUTINE UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_PROMOTING_TIME ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & LOC_PROMOTING_TIME END SUBROUTINE UPDATE_PROMOTING_TIME SUBROUTINE UPDATE_FLOP_STATS_CB_PROMOTE(COST, NIV) DOUBLE PRECISION :: COST INTEGER :: NIV IF (NIV.EQ.1) THEN !$OMP CRITICAL(cb_flop_cost_pro_cri) FLOP_CB_PROMOTE = FLOP_CB_PROMOTE + COST !$OMP END CRITICAL(cb_flop_cost_pro_cri) ELSE !$OMP CRITICAL(acc_cb_flop_cost_pro_cri) ACC_FLOP_CB_PROMOTE = ACC_FLOP_CB_PROMOTE + COST !$OMP END CRITICAL(acc_cb_flop_cost_pro_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_CB_PROMOTE SUBROUTINE UPDATE_FLOP_STATS_CB_DEMOTE(COST, NIV) DOUBLE PRECISION :: COST INTEGER :: NIV IF (NIV.EQ.1) THEN !$OMP CRITICAL(cb_flop_cost_dem_cri) FLOP_CB_DEMOTE = FLOP_CB_DEMOTE + COST !$OMP END CRITICAL(cb_flop_cost_dem_cri) ELSE !$OMP CRITICAL(acc_cb_flop_cost_dem_cri) ACC_FLOP_CB_DEMOTE = ACC_FLOP_CB_DEMOTE + COST !$OMP END CRITICAL(acc_cb_flop_cost_dem_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_CB_DEMOTE SUBROUTINE UPDATE_FLOP_STATS_DEMOTE(LR_B, NIV, REC_ACC) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER(8) :: M,N,K INTEGER :: NIV DOUBLE PRECISION :: HR_COST,BUILDQ_COST LOGICAL, OPTIONAL :: REC_ACC M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K,8) HR_COST = dble(4_8*K*K*K/3_8 + 4_8*K*M*N - 2_8*(M+N)*K*K) IF (LR_B%ISLR) THEN BUILDQ_COST = dble(4_8*K*K*M - K*K*K) ELSE BUILDQ_COST = 0.0d0 END IF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_DEMOTE = FLOP_DEMOTE + HR_COST + BUILDQ_COST IF (present(REC_ACC)) THEN IF (REC_ACC) THEN FLOP_REC_ACC = FLOP_REC_ACC + HR_COST+BUILDQ_COST ENDIF ENDIF !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + (HR_COST + BUILDQ_COST) IF (present(REC_ACC)) THEN IF (REC_ACC) THEN ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC +HR_COST+BUILDQ_COST ENDIF ENDIF !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_DEMOTE SUBROUTINE UPDATE_FLOP_STATS_REC_ACC(LR_B, NIV, K1, K2, BUILDQ1) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER,INTENT(IN) :: NIV, K1, K2 LOGICAL,INTENT(IN) :: BUILDQ1 INTEGER(8) :: M,N,K DOUBLE PRECISION :: HR_COST, BUILDQ_COST, GS_COST, UPDT_COST, & TOT_COST M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K - K1,8) GS_COST = dble((4_8*(K1)+1_8)*M*K2) HR_COST = dble(4_8*K*K*K/3_8 + 4_8*K*M*K2 - 2_8*(M+K2)*K*K) IF (BUILDQ1) THEN BUILDQ_COST = dble(4_8*K*K*M - K*K*K) UPDT_COST = dble(2_8*K*K2*N) ELSE BUILDQ_COST = 0.0d0 UPDT_COST = 0.0d0 ENDIF TOT_COST = BUILDQ_COST + HR_COST + GS_COST + UPDT_COST IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_DEMOTE = FLOP_DEMOTE + TOT_COST FLOP_REC_ACC = FLOP_REC_ACC + TOT_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + TOT_COST ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + TOT_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_REC_ACC SUBROUTINE UPDATE_FLOP_STATS_PANEL(NFRONT, NPIV, NIV, SYM) INTEGER :: NFRONT, NPIV, NIV, SYM DOUBLE PRECISION :: COST_PANEL, COST_TRSM IF (SYM.EQ.0) THEN COST_TRSM = dble(2 * NPIV-1) * dble(NPIV) & * dble(NFRONT-NPIV) COST_PANEL = dble(NPIV) * dble(NPIV - 1) & * dble(4 * NPIV + 1)/dble(6) ELSE COST_TRSM = dble(NPIV) * dble(NPIV) * dble(NFRONT-NPIV) COST_PANEL = dble(NPIV) * dble(NPIV - 1) & * dble(2 * NPIV + 1)/dble(6) ENDIF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_PANEL = FLOP_PANEL + COST_PANEL FLOP_TRSM = FLOP_TRSM + COST_TRSM !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_PANEL = ACC_FLOP_PANEL + COST_PANEL ACC_FLOP_TRSM = ACC_FLOP_TRSM + COST_TRSM !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_PANEL SUBROUTINE UPDATE_FLOP_STATS_TRSM(LRB, NIV, LorU, K470) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: NIV, LorU, K470 DOUBLE PRECISION :: LR_FLOP_COST, FR_FLOP_COST IF (LorU.EQ.0) THEN FR_FLOP_COST = dble(LRB%M)*dble(LRB%N)*dble(LRB%N) IF (LRB%ISLR) THEN LR_FLOP_COST = dble(LRB%K)*dble(LRB%N)*dble(LRB%N) ELSE LR_FLOP_COST = FR_FLOP_COST ENDIF ELSE IF (K470.EQ.1) THEN FR_FLOP_COST = dble(LRB%M-1)*dble(LRB%N)*dble(LRB%N) ELSE FR_FLOP_COST = dble(LRB%M-1)*dble(LRB%M)*dble(LRB%N) ENDIF IF (LRB%ISLR) THEN IF (K470.EQ.1) THEN LR_FLOP_COST = dble(LRB%N-1)*dble(LRB%N)*dble(LRB%K) ELSE LR_FLOP_COST = dble(LRB%M-1)*dble(LRB%M)*dble(LRB%K) ENDIF ELSE LR_FLOP_COST = FR_FLOP_COST ENDIF ENDIF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_FR_TRSM = FLOP_FR_TRSM + FR_FLOP_COST FLOP_LR_TRSM = FLOP_LR_TRSM + LR_FLOP_COST LR_FLOP_GAIN = LR_FLOP_GAIN + FR_FLOP_COST & - LR_FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_FR_TRSM = ACC_FLOP_FR_TRSM + FR_FLOP_COST ACC_FLOP_LR_TRSM = ACC_FLOP_LR_TRSM + LR_FLOP_COST ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + FR_FLOP_COST & - LR_FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) END IF END SUBROUTINE UPDATE_FLOP_STATS_TRSM SUBROUTINE UPDATE_FLOP_STATS_LRB_PRODUCT(LRB1, LRB2, TRANSB1, & TRANSB2, NIV, COMPRESS_MID_PRODUCT, RANK_IN, BUILDQ, & IS_DIAG, K480, REC_ACC_IN) !$ USE OMP_LIB TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 CHARACTER(len=1), INTENT(IN) :: TRANSB1, TRANSB2 LOGICAL, INTENT(IN), OPTIONAL :: BUILDQ, IS_DIAG, REC_ACC_IN INTEGER, INTENT(IN), OPTIONAL :: NIV, RANK_IN, & COMPRESS_MID_PRODUCT, K480 LOGICAL :: REC_ACC DOUBLE PRECISION :: LR_FLOP_COST, LR_FLOP_COST_OUT, FR_FLOP_COST DOUBLE PRECISION :: HR_COST, BUILDQ_COST DOUBLE PRECISION :: M1,N1,K1,M2,N2,K2,RANK CHARACTER(len=2) :: PROD, TRANS IF(present(K480).AND.present(REC_ACC_IN)) THEN IF (K480.GE.4) THEN REC_ACC = REC_ACC_IN ELSE REC_ACC = .FALSE. ENDIF ELSE REC_ACC = .FALSE. ENDIF 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) IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) THEN PROD = '00' ELSE IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN PROD = '10' ELSE IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN PROD = '01' ELSE PROD = '11' END IF IF ((TRANSB1=='N').AND.(TRANSB2=='N')) THEN TRANS = 'NN' ELSE IF ((TRANSB1=='T').AND.(TRANSB2=='N')) THEN TRANS = 'TN' ELSE IF ((TRANSB1=='N').AND.(TRANSB2=='T')) THEN TRANS = 'NT' ELSE TRANS = 'TT' END IF LR_FLOP_COST_OUT = 0.0D0 HR_COST = 0.0D0 BUILDQ_COST = 0.0D0 SELECT CASE (PROD) CASE('00') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*M1*N2*N1 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*M1*N2*N1 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*M1*M2*N1 CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 LR_FLOP_COST = 2.0D0*N1*M2*M1 END SELECT CASE('10') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*K1*N2*N1 + 2.0D0*M1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K1 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*K1*N2*M1 + 2.0D0*N1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K1 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*K1*M2*N1 + 2.0D0*M1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K1 CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 LR_FLOP_COST = 2.0D0*K1*M2*M1 + 2.0D0*N1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K1 END SELECT CASE('01') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*M1*K2*N1 + 2.0D0*M1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K2 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*N1*K2*M1 + 2.0D0*N1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K2 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*M1*K2*N1 + 2.0D0*M1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K2 CASE('TT') FR_FLOP_COST = 2*N1*M2*M1 LR_FLOP_COST = 2.0D0*N1*K2*M1 + 2.0D0*N1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K2 END SELECT CASE('11') IF (COMPRESS_MID_PRODUCT.GE.1) THEN HR_COST = 4.0D0*RANK*RANK*RANK/3.0D0 + & 4.0D0*RANK*K1*K2 - & 2.0D0*(K1+K2)*RANK*RANK IF (BUILDQ) THEN BUILDQ_COST = 4.0D0*RANK*RANK*K1 - RANK*RANK*RANK ENDIF ENDIF SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*RANK + 2.0D0*K2*N2*RANK + & 2.0D0*M1*N2*RANK LR_FLOP_COST_OUT = 2.0D0*M1*N2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*K2 + 2.0D0*M1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*N2*K2 + 2.0D0*M1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K1 ENDIF ENDIF CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*RANK + 2.0D0*K2*N2*RANK + & 2.0D0*N1*N2*RANK LR_FLOP_COST_OUT = 2.0D0*N1*N2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*K2 + 2.0D0*N1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N2*K2 + 2.0D0*N1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K1 ENDIF ENDIF CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*RANK + 2.0D0*K2*M2*RANK + & 2.0D0*M1*M2*RANK LR_FLOP_COST_OUT = 2.0D0*M1*M2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*K2 + 2.0D0*M1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M2*K2 + 2.0D0*M1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K1 ENDIF ENDIF CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*RANK + 2.0D0*K2*M2*RANK + & 2.0D0*N1*M2*RANK LR_FLOP_COST_OUT = 2.0D0*N1*M2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*K2 + 2.0D0*N1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*M2*K2 + 2.0D0*N1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K1 ENDIF ENDIF END SELECT END SELECT IF (present(IS_DIAG)) THEN IF (IS_DIAG) THEN FR_FLOP_COST = FR_FLOP_COST/2.0D0 LR_FLOP_COST = LR_FLOP_COST/2.0D0 ENDIF ENDIF IF (present(K480)) THEN IF (K480.GE.3) THEN LR_FLOP_COST = LR_FLOP_COST - LR_FLOP_COST_OUT LR_FLOP_COST_OUT = 0.0D0 IF (REC_ACC) THEN IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_REC_ACC = FLOP_REC_ACC + LR_FLOP_COST & + HR_COST + BUILDQ_COST FLOP_DEMOTE = FLOP_DEMOTE + LR_FLOP_COST & + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + LR_FLOP_COST & + HR_COST + BUILDQ_COST ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + LR_FLOP_COST & + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF ENDIF ENDIF ENDIF IF (.NOT.REC_ACC) THEN IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) LR_FLOP_GAIN = LR_FLOP_GAIN + FR_FLOP_COST - LR_FLOP_COST FLOP_FR_UPDT = FLOP_FR_UPDT + FR_FLOP_COST FLOP_LR_UPDT = FLOP_LR_UPDT + LR_FLOP_COST FLOP_LR_UPDT_OUT = FLOP_LR_UPDT_OUT + LR_FLOP_COST_OUT FLOP_DEMOTE = FLOP_DEMOTE + HR_COST + BUILDQ_COST FLOP_RMB = FLOP_RMB + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + & FR_FLOP_COST - LR_FLOP_COST ACC_FLOP_FR_UPDT = ACC_FLOP_FR_UPDT + FR_FLOP_COST ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + LR_FLOP_COST ACC_FLOP_LR_UPDT_OUT = ACC_FLOP_LR_UPDT_OUT + & LR_FLOP_COST_OUT ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + HR_COST + BUILDQ_COST ACC_FLOP_RMB = ACC_FLOP_RMB + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF ENDIF END SUBROUTINE UPDATE_FLOP_STATS_LRB_PRODUCT SUBROUTINE UPDATE_FLOP_STATS_DEC_ACC(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) IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) LR_FLOP_GAIN = LR_FLOP_GAIN - FLOP_COST FLOP_LR_UPDT = FLOP_LR_UPDT + FLOP_COST FLOP_LR_UPDT_OUT = FLOP_LR_UPDT_OUT + FLOP_COST FLOP_DEC_ACC = FLOP_DEC_ACC + FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN - FLOP_COST ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + FLOP_COST ACC_FLOP_LR_UPDT_OUT = ACC_FLOP_LR_UPDT_OUT + & FLOP_COST ACC_FLOP_DEC_ACC = ACC_FLOP_DEC_ACC + FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_DEC_ACC SUBROUTINE UPDATE_FLOPS_STATS_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)) ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + COST_PER_PROC RETURN END SUBROUTINE UPDATE_FLOPS_STATS_ROOT SUBROUTINE INIT_STATS_FRONT(NFRONT,INODE,NASS,NCB) INTEGER,INTENT(IN) :: NFRONT,INODE,NASS,NCB FRONT_L11_BLR_SAVINGS = 0.D0 FRONT_U11_BLR_SAVINGS = 0.D0 FRONT_L21_BLR_SAVINGS = 0.D0 FRONT_U12_BLR_SAVINGS = 0.D0 LR_FLOP_GAIN = 0.D0 FLOP_CB_DEMOTE = 0.D0 FLOP_CB_PROMOTE = 0.D0 FLOP_FR_UPDT = 0.D0 FLOP_LR_UPDT = 0.D0 FLOP_LR_UPDT_OUT = 0.D0 FLOP_RMB = 0.D0 FLOP_FR_TRSM = 0.D0 FLOP_LR_TRSM = 0.D0 FLOP_DEMOTE = 0.D0 FLOP_DEC_ACC = 0.D0 FLOP_REC_ACC = 0.D0 FLOP_PANEL = 0.D0 FLOP_TRSM = 0.D0 END SUBROUTINE INIT_STATS_FRONT SUBROUTINE INIT_STATS_GLOBAL(id) use DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id ACC_MRY_CB_GAIN = 0.D0 ACC_MRY_CB_FR = 0.D0 ACC_FLOP_CB_DEMOTE = 0.D0 ACC_FLOP_CB_PROMOTE = 0.D0 ACC_FLOP_FR_FACTO = 0.D0 ACC_FLOP_LR_FACTO = 0.D0 ACC_FLOP_FR_UPDT = 0.D0 ACC_FLOP_LR_UPDT = 0.D0 ACC_FLOP_LR_UPDT_OUT = 0.D0 ACC_FLOP_RMB = 0.D0 ACC_FLOP_FR_TRSM = 0.D0 ACC_FLOP_LR_TRSM = 0.D0 ACC_FLOP_DEMOTE = 0.D0 ACC_FLOP_TRSM = 0.D0 ACC_FLOP_DEC_ACC = 0.D0 ACC_FLOP_REC_ACC = 0.D0 ACC_FLOP_PANEL = 0.D0 ACC_FLOP_FRFRONTS = 0.D0 ACC_FLOP_FR_SOLVE = 0.D0 ACC_FLOP_LR_SOLVE = 0.D0 ACC_LR_FLOP_GAIN = 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 ACC_FR_MRY = 0.D0 GLOBAL_BLR_SAVINGS = 0.D0 ACC_UPDT_TIME = 0.D0 ACC_UPDT_TIME_OUT = 0.D0 ACC_RMB_TIME = 0.D0 ACC_PROMOTING_TIME = 0.D0 ACC_DEMOTING_TIME = 0.D0 ACC_CB_DEMOTING_TIME = 0.D0 ACC_FRPANELS_TIME = 0.0D0 ACC_FAC_I_TIME = 0.0D0 ACC_FAC_MQ_TIME = 0.0D0 ACC_FAC_SQ_TIME = 0.0D0 ACC_FRFRONTS_TIME = 0.0D0 ACC_TRSM_TIME = 0.D0 ACC_LR_MODULE_TIME = 0.D0 CNT_NODES = 0 STEP_STATS => id%STEP END SUBROUTINE INIT_STATS_GLOBAL SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NCB, & SYM, INODE, NELIM) INTEGER,INTENT(IN) :: NASS, NCB, SYM, INODE, NELIM DOUBLE PRECISION :: FRONT_BLR_SAVINGS, FRONT_FR_MRY IF (SYM .GT. 0) THEN FRONT_BLR_SAVINGS = FRONT_L11_BLR_SAVINGS & + FRONT_L21_BLR_SAVINGS FRONT_FR_MRY = dble(NASS-NELIM) * & (dble(NASS-NELIM)+1.D0)/2.D0 & + dble(NASS-NELIM) * dble(NCB+NELIM) ELSE FRONT_BLR_SAVINGS = FRONT_L11_BLR_SAVINGS & + FRONT_L21_BLR_SAVINGS & + FRONT_U11_BLR_SAVINGS & + FRONT_U12_BLR_SAVINGS FRONT_FR_MRY = dble(NASS-NELIM) * dble(NASS-NELIM) & + 2.0D0 * dble(NASS-NELIM) * dble(NCB+NELIM) END IF ACC_FR_MRY = ACC_FR_MRY + FRONT_FR_MRY GLOBAL_BLR_SAVINGS = GLOBAL_BLR_SAVINGS + FRONT_BLR_SAVINGS END SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE1 SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, & SYM, INODE, NELIM) INTEGER,INTENT(IN) :: NASS, NFRONT, SYM, INODE, NELIM IF (SYM .GT. 0) THEN ACC_FR_MRY = ACC_FR_MRY + & dble(NASS-NELIM) * & (dble(NASS-NELIM)+1.D0)/2.D0 & + dble(NASS-NELIM) * dble(NFRONT-NASS+NELIM) ELSE ACC_FR_MRY = ACC_FR_MRY + & dble(NASS-NELIM) * dble(NASS-NELIM) & + 2.0D0 * dble(NASS-NELIM) * dble(NFRONT-NASS+NELIM) ENDIF END SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE2 SUBROUTINE STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, & SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS) INTEGER,INTENT(IN) :: NROW, NCB, SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS DOUBLE PRECISION :: MRY_CB_FR IF (SYM==0) THEN MRY_CB_FR = dble(NCB)*dble(NROW) ELSE MRY_CB_FR = dble(NCB-NROW)*dble(NROW) + & dble(NROW)*dble(NROW+1)/2.D0 ENDIF ACC_MRY_CB_FR = ACC_MRY_CB_FR + MRY_CB_FR ACC_MRY_CB_GAIN = ACC_MRY_CB_GAIN + FRONT_CB_BLR_SAVINGS END SUBROUTINE STATS_COMPUTE_MRY_FRONT_CB SUBROUTINE STATS_STORE_BLR_PANEL_MRY(BLR_PANEL, NB_INASM, & NB_INCB, DIR, NIV) INTEGER,INTENT(IN) :: NB_INASM, NB_INCB, NIV TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(NB_INASM+NB_INCB) CHARACTER(len=1) :: DIR INTEGER :: I IF (NB_INASM.GT.0.AND.DIR .EQ.'V') THEN ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + & dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N) ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N) ENDIF DO I = 1 , NB_INASM ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + & dble(2)*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) IF (BLR_PANEL(I)%ISLR) THEN ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(4)*(dble(BLR_PANEL(I)%M)+dble(BLR_PANEL(I)%N))* & dble(BLR_PANEL(I)%K) IF (DIR .EQ. 'H') THEN IF (NIV .EQ. 1) THEN FRONT_U11_BLR_SAVINGS = & FRONT_U11_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ELSE IF (NIV .EQ. 1) THEN FRONT_L11_BLR_SAVINGS = & FRONT_L11_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M) + dble(BLR_PANEL(I)%N ) ENDIF ENDIF ELSE ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(2)*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) ENDIF END DO DO I = NB_INASM + 1 , NB_INASM + NB_INCB IF (BLR_PANEL(I)%ISLR) THEN IF (DIR .EQ. 'H') THEN IF (NIV .EQ. 1) THEN FRONT_U12_BLR_SAVINGS = & FRONT_U12_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ELSE IF (NIV .EQ. 1) THEN FRONT_L21_BLR_SAVINGS = & FRONT_L21_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble ( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ENDIF END IF END DO END SUBROUTINE STATS_STORE_BLR_PANEL_MRY SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE1( NFRONT, NASS, NPIV, & KEEP50, INODE) INTEGER,INTENT(IN) :: NFRONT, KEEP50, NASS, NPIV, INODE DOUBLE PRECISION :: FLOP_FR_FACTO CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & KEEP50, 1, FLOP_FR_FACTO) ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + LR_FLOP_GAIN ACC_FLOP_FR_UPDT = ACC_FLOP_FR_UPDT + FLOP_FR_UPDT ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + FLOP_LR_UPDT ACC_FLOP_LR_UPDT_OUT= ACC_FLOP_LR_UPDT_OUT+ FLOP_LR_UPDT_OUT ACC_FLOP_RMB = ACC_FLOP_RMB + FLOP_RMB ACC_FLOP_FR_TRSM = ACC_FLOP_FR_TRSM + FLOP_FR_TRSM ACC_FLOP_LR_TRSM = ACC_FLOP_LR_TRSM + FLOP_LR_TRSM ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + FLOP_DEMOTE ACC_FLOP_CB_DEMOTE = ACC_FLOP_CB_DEMOTE + FLOP_CB_DEMOTE ACC_FLOP_CB_PROMOTE = ACC_FLOP_CB_PROMOTE + FLOP_CB_PROMOTE ACC_FLOP_DEC_ACC = ACC_FLOP_DEC_ACC + FLOP_DEC_ACC ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + FLOP_REC_ACC ACC_FLOP_TRSM = ACC_FLOP_TRSM + FLOP_TRSM ACC_FLOP_PANEL = ACC_FLOP_PANEL + FLOP_PANEL END SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE1 SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE2( NFRONT, NASS, & KEEP50, INODE, NELIM) INTEGER,INTENT(IN) :: NFRONT, KEEP50, NASS, INODE, NELIM DOUBLE PRECISION :: FLOP_FR_FACTO CALL MUMPS_GET_FLOPS_COST(NFRONT, NASS-NELIM, NASS, & KEEP50, 2, FLOP_FR_FACTO) ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO END SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE2 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_FR_FACTO NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP_FR_FACTO = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP_FR_FACTO = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO END SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2 SUBROUTINE UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, SYM, & NIV) INTEGER, INTENT(IN) :: NFRONT, NPIV, NASS, SYM, NIV DOUBLE PRECISION :: FLOP_FRFRONTS, FLOP_SOLVE CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP_FRFRONTS) ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + FLOP_FRFRONTS FLOP_SOLVE = dble(NASS)*dble(NASS) + & dble(NFRONT-NASS)*dble(NASS) IF (SYM.EQ.0) FLOP_SOLVE = 2.0D0*FLOP_SOLVE ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + FLOP_SOLVE ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + FLOP_SOLVE END SUBROUTINE UPDATE_FLOP_STATS_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_FRFRONTS NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP_FRFRONTS = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP_FRFRONTS = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + FLOP_FRFRONTS END SUBROUTINE UPD_FLOP_FRFRONT_SLAVE SUBROUTINE COMPUTE_GLOBAL_GAINS(NB_ENTRIES_FACTOR, & FLOP_NUMBER, NIV, PROKG, MPG) INTEGER(KIND=8), INTENT(IN) :: NB_ENTRIES_FACTOR INTEGER, INTENT(IN) :: NIV, MPG LOGICAL, INTENT(IN) :: PROKG DOUBLE PRECISION , INTENT(IN) :: FLOP_NUMBER 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 (ACC_FR_MRY .EQ. 0) THEN GLOBAL_MRY_LPRO_COMPR = 100.0D0 ELSE GLOBAL_MRY_LPRO_COMPR = 100.0D0 * & GLOBAL_BLR_SAVINGS/ACC_FR_MRY ENDIF IF (ACC_MRY_CB_FR .EQ. 0) THEN ACC_MRY_CB_FR = 100.0D0 END IF IF (NB_ENTRIES_FACTOR.EQ.0) THEN FACTOR_PROCESSED_FRACTION = 100.0D0 GLOBAL_MRY_LTOT_COMPR = 100.0D0 ELSE FACTOR_PROCESSED_FRACTION = 100.0D0 * & ACC_FR_MRY/dble(NB_ENTRIES_FACTOR) GLOBAL_MRY_LTOT_COMPR = & 100.0D0*GLOBAL_BLR_SAVINGS/dble(NB_ENTRIES_FACTOR) ENDIF TOTAL_FLOP = FLOP_NUMBER ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN & + ACC_FLOP_DEMOTE RETURN END SUBROUTINE COMPUTE_GLOBAL_GAINS SUBROUTINE SAVEandWRITE_GAINS(LOCAL, K489, DKEEP, N, & DEPTH, BCKSZ, NASSMIN, NFRONTMIN, SYM, K486, & K472, K475, K478, K480, K481, K483, K484, K485, K467, & NBTREENODES, NPROCS, MPG, PROKG) INTEGER, INTENT(IN) :: LOCAL,K489,N,DEPTH,BCKSZ,NASSMIN, & NFRONTMIN, K486, NBTREENODES, MPG, K467, & K472, K475, K478, K480, K481, K483, K484, K485, SYM, NPROCS 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)') & ' Settings for Block Low-Rank (BLR) are :' WRITE(MPG,'(A)') ' BLR algorithm characteristics :' WRITE(MPG,'(A,A)') ' Variant used: FSCU ', & '(Factor-Solve-Compress-Update)' SELECT CASE (K489) CASE (0) CASE (1) WRITE(MPG,'(A)') & ' Experimental CB compression (for stats only)' CASE DEFAULT WRITE(*,*)' Internal error K489=',K489 CALL MUMPS_ABORT() END SELECT IF (K472.EQ.0) THEN WRITE(MPG,'(A,A,I4)') ' Target BLR block size (fixed)', & ' =', & BCKSZ ELSE WRITE(MPG,'(A,A,I4,A,I4)') & ' Target BLR block size (variable)', & ' =', & 128, ' -', BCKSZ ENDIF WRITE(MPG,'(A,A,ES8.1)') ' RRQR precision (epsilon) ', & ' =', & 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)') & ' 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(ACC_FLOP_LR_FACTO+ACC_FLOP_FRFRONTS) DKEEP(61)=dble(100*(ACC_FLOP_LR_FACTO+ & ACC_FLOP_FRFRONTS) /TOTAL_FLOP) IF (PROK) THEN WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' Total theoretical full-rank OPC (i.e. FR OPC) =' & ,TOTAL_FLOP,' (',100*TOTAL_FLOP/TOTAL_FLOP,'%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' Total effective OPC (% FR OPC) =' & ,ACC_FLOP_LR_FACTO+ACC_FLOP_FRFRONTS,' (' &,100*(ACC_FLOP_LR_FACTO+ACC_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.1.2/src/csol_bwd_aux.F0000664000175000017500000011145013164366264016310 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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(40), 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 MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) #if defined(RHSCOMP_BYROWS) COMPLEX RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX RHSCOMP(LRHSCOMP,NRHS) #endif 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 DOUBLE PRECISION :: TIME_TMP 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 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE CMUMPS_OOC 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(40), 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 MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) #if defined(RHSCOMP_BYROWS) COMPLEX RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX RHSCOMP(LRHSCOMP,NRHS) #endif INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED 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(8) :: P_UPDATE, P_SOL_MAS 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_TMP, IPOSINRHSCOMP_PANEL DOUBLE PRECISION :: TIME_TMP INTEGER JBDEB, JBFIN, NRHS_B, allocok 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 MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE, ctrsv, ctrsm, cgemv, cgemm 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 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. FEUILLE) 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 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 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP) = W(POSWCB+1+JJ) #else RHSCOMP(IPOSINRHSCOMP,K) = W(POSWCB+1+JJ) #endif ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( KEEP(237).GT. 0 ) 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)), & SLAVEF) .eq. MYID ) THEN IF ( KEEP(237).GT. 0 ) 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 IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF (KEEP(201).GT.0) 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(IW( IPOS + 3 )) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 in 41S : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - LONG*NRHS_B .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 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + NPIV * NRHS_B PLEFTW = P_SOL_MAS + NROW_L * NRHS_B 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).EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE #endif CALL cgemm( 'T', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE #endif CALL cgemm( 'N', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF IF (KEEP(201).GT.0) 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 - NROW_L * NRHS_B 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 ) 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = W2(I) #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) #endif I = I+1 ENDDO ELSE DO JJ = J1,J2 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) + W2(I) #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) #endif 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) 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) 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 )) IF (KEEP(350).EQ.0) THEN DO K=JBDEB, JBFIN DO JJ = J1, J2 W(IFR8+JJ-J1+(K-JBDEB)*LIELL) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif END DO END DO ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*) "Internal error CMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR8 = IFR8 + 1 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(K,IPOSINRHSCOMP_TMP) #else W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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 ELSE WRITE(*,*) "Internal error CMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF IF ( KEEP(201).EQ.1 .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 (KEEP(350).EQ.0) THEN CALL cgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( PTWCB_PANEL + int(NBJ,8) ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ELSE IF (NCB_PANEL - NCB.NE. 0) THEN CALL cgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), & 1, ONE, & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF IF (NCB .NE. 0) THEN CALL cgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + NPIV ), & 1, ONE, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF ENDIF ENDIF IF (KEEP(350).eq.0) THEN CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (KEEP(350).eq.0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(PTWCB_PANEL+int(NBJ,8)),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in CMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else 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 ENDIF ENDIF IF (KEEP(350).eq.0) THEN CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in CMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF 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 IF (KEEP(350).EQ.0) THEN CALL cgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & W(PTRACB(STEP(INODE))), 1 ) ELSE CALL cgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE IF (KEEP(350).EQ.0) THEN CALL cgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, W(PTRACB(STEP(INODE))),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in CMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL cgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF END IF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL ctrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & W(PTRACB(STEP(INODE))),1) ELSE CALL ctrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL ctrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & W(PTRACB(STEP(INODE))),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) & "Internal error in CMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() #else CALL ctrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif 1234 CONTINUE IF (KEEP(201).GT.0) 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO I = 1, NPIV DO K=JBDEB,JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) #else RHSCOMP( IPOSINRHSCOMP_TMP , K ) = & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) #endif ENDDO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*)"Internal error in CMUMPS_BACKSLV_TRAITER_MESSAGE" CALL MUMPS_ABORT() ENDIF IN = INODE 200 IN = FILS(IN) IF (IN .GT. 0) GOTO 200 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, 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 ( KEEP(237).GT.0 ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( KEEP(237).GT.0 ) 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)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & SLAVEF ) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 IF (NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, FEUILLE, 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=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 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 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE DEALLOCATE(DEJA_SEND) RETURN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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.1.2/src/zfac_process_blocfacto.F0000664000175000017500000006605413164366265020346 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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 USE ZMUMPS_LOAD USE ZMUMPS_LR_STATS USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_DECOMPRESS_PANEL, & ZMUMPS_COMPRESS_PANEL, & ZMUMPS_BLR_UPDATE_TRAILING, & ZMUMPS_FAKE_COMPRESS_CB USE ZMUMPS_ANA_LR, ONLY : GET_CUT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ), 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), 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) :: LAELL INTEGER(8) :: POSELT INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, LPOS1, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTBL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX(kind=8) ONE,ALPHA PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO INTEGER :: SEND_LR_INT, NELIM, NPARTSASS_MASTER, & CURRENT_BLR_PANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: SEND_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U 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 INTEGER T1, T2, COUNT_RATE COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL :: DYNAMIC_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE 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, CURRENT_BLR_PANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF IF ( SEND_LR ) THEN LAELL = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LAELL = int(NPIV,8) * int(NCOL,8) ENDIF IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLUS, IERROR) IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN LP=ICNTL(1) WRITE(LP,*) &" FAILURE, WORKSPACE TOO SMALL DURING ZMUMPS_PROCESS_BLOCFACTO" ENDIF GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ZMUMPS_PROCESS_BLOCFACTO, LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR( LAELL-LRLUS, IERROR ) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN LP=ICNTL(1) WRITE(LP,*) &" FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_PROCESS_BLOCFACTO" ENDIF IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LAELL,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 ( SEND_LR ) 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))) ALLOCATE(BEGS_BLR_U(NB_BLR_U+2)) CALL ZMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, KEEP(470), & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTRIST(STEP(INODE))+XXNBPR)) DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) #else DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) POSELT = PTRAST(STEP(INODE)) LCONT1 = IW( IOLDPS +KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 +KEEP(IXSZ)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) ELSE CALL ZMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS) 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(IPOS), NCOL1, A(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(IPOS), NCOL1, A(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF (KEEP(486) .GT.0) THEN CALL SYSTEM_CLOCK(T1) ENDIF IF (DYNAMIC_ALLOC) THEN CALL ztrsm('L','L','N','N',NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, A(LPOS2), NCOL1) ELSE CALL ztrsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, A(LPOS2), NCOL1) ENDIF IF (KEEP(486) .GT.0) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_TRSM_TIME = ACC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (SEND_LR) THEN 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 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) MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) 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)) CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL & (A, LA, POSELT, IFLAG, IERROR, NCOL1, & BEGS_BLR_L, NB_BLR_L+1, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #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. & ( .NOT. SEND_LR .OR. (NPIV .EQ.0) .OR. & (KEEP(485).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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (SEND_LR) THEN IF (NELIM.GT.0) THEN IF (DYNAMIC_ALLOC) THEN LPOS1 = int(NPIV+1,8) CALL zgemm('N','N', NELIM,NROW1,NPIV, & ALPHA,DYN_BLOCFACTO(LPOS1),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ELSE LPOS1 = POSBLOCFACTO+int(NPIV,8) CALL zgemm('N','N', NELIM,NROW1,NPIV, & ALPHA,A(LPOS1),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, & BLR_L, NB_BLR_L+1, & BLR_U, NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, KEEP(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_UPDT_TIME = ACC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & 0, NPARTSCB, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, & .FALSE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L, CURRENT_BLR, 'V', NCOL1, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (KEEP(201).eq.1) 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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF ENDIF ELSE IF (DYNAMIC_ALLOC) THEN LPOS1 = int(NPIV+1,8) CALL zgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,DYN_BLOCFACTO(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ELSE LPOS1 = POSBLOCFACTO+int(NPIV,8) CALL zgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,A(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(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 (SEND_LR) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, .FALSE.) DEALLOCATE(BLR_U) CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8, .TRUE.) DEALLOCATE(BLR_L) ENDIF ENDIF IF (DYNAMIC_ALLOC) THEN DEALLOCATE(DYN_BLOCFACTO) DEALLOCATE(DYN_PIVINFO) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,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 (SEND_LR) 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 (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN CALL ZMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_L, NB_BLR_L+1, & BEGS_BLR_U, NB_BLR_U+1, 1, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., NPIV1, KEEP(484)) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 (SEND_LR) 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 ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_L)) DEALLOCATE(BEGS_BLR_L) 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, K470, & 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, K470 CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(OUT) :: IERR, IFLAG, IERROR 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 :: LRFORM, K, M, N, KSVD 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, & LRFORM, 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & KSVD, 1, & MPI_INTEGER, COMM, IERR ) IF (DIR.EQ.'H') THEN IF (K470.EQ.1) THEN BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M ELSE BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + N ENDIF ELSE BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M ENDIF IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, KSVD, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (LRFORM .NE. BLR_U(I)%LRFORM) THEN WRITE(*,*) "Internal error 2 in ALLOC_LRB", & LRFORM, BLR_U(I)%LRFORM ENDIF 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.1.2/src/sfac_mem_free_block_cb.F0000664000175000017500000000553513164366262020234 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_FREE_BLOCK_CB(SSARBR, MYID, N, IPOSBLOCK, & RPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) USE SMUMPS_LOAD IMPLICIT NONE INTEGER(8) :: RPOSBLOCK 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 INCLUDE 'mumps_headers.h' IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ) SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) ) 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 ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF ENDIF 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 IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF ENDIF 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 MUMPS_5.1.2/src/clr_stats.F0000664000175000017500000012431113164366265015636 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE CMUMPS_LR_STATS USE CMUMPS_LR_TYPE IMPLICIT NONE DOUBLE PRECISION :: ACC_MRY_CB_GAIN, & ACC_MRY_CB_FR, & FRONT_L11_BLR_SAVINGS, & FRONT_U11_BLR_SAVINGS, & FRONT_L21_BLR_SAVINGS, & FRONT_U12_BLR_SAVINGS, & ACC_FR_MRY, & GLOBAL_BLR_SAVINGS, & GLOBAL_MRY_LPRO_COMPR, & GLOBAL_MRY_LTOT_COMPR INTEGER :: CNT_NODES DOUBLE PRECISION :: FLOP_FR_UPDT, & FLOP_LR_UPDT, & FLOP_LR_UPDT_OUT, & FLOP_RMB, & FLOP_FR_TRSM, & FLOP_LR_TRSM, & FLOP_PANEL, & FLOP_TRSM, & FLOP_DEC_ACC, & FLOP_REC_ACC, & FLOP_DEMOTE, & FLOP_CB_DEMOTE, & FLOP_CB_PROMOTE, & LR_FLOP_GAIN DOUBLE PRECISION :: ACC_LR_FLOP_GAIN DOUBLE PRECISION :: ACC_FLOP_FR_FACTO, & ACC_FLOP_LR_FACTO, & ACC_FLOP_FR_TRSM, & ACC_FLOP_LR_TRSM, & ACC_FLOP_FR_UPDT, & ACC_FLOP_LR_UPDT, & ACC_FLOP_LR_UPDT_OUT, & ACC_FLOP_RMB, & ACC_FLOP_DEMOTE, & ACC_FLOP_CB_DEMOTE, & ACC_FLOP_CB_PROMOTE, & ACC_FLOP_TRSM, & ACC_FLOP_DEC_ACC, & ACC_FLOP_REC_ACC, & ACC_FLOP_PANEL, & ACC_FLOP_FRFRONTS, & ACC_FLOP_FR_SOLVE, & ACC_FLOP_LR_SOLVE DOUBLE PRECISION :: FACTOR_PROCESSED_FRACTION INTEGER(KIND=8) :: FACTOR_SIZE DOUBLE PRECISION :: TOTAL_FLOP DOUBLE PRECISION :: BLR_TIME_LRGROUPING DOUBLE PRECISION :: BLR_TIME_SEPGROUPING DOUBLE PRECISION :: BLR_TIME_GETHALO DOUBLE PRECISION :: BLR_TIME_KWAY DOUBLE PRECISION :: BLR_TIME_GNEW DOUBLE PRECISION :: ACC_UPDT_TIME DOUBLE PRECISION :: ACC_RMB_TIME DOUBLE PRECISION :: ACC_UPDT_TIME_OUT DOUBLE PRECISION :: ACC_PROMOTING_TIME DOUBLE PRECISION :: ACC_DEMOTING_TIME DOUBLE PRECISION :: ACC_CB_DEMOTING_TIME DOUBLE PRECISION :: ACC_LR_MODULE_TIME DOUBLE PRECISION :: ACC_TRSM_TIME DOUBLE PRECISION :: ACC_FRPANELS_TIME DOUBLE PRECISION :: ACC_FAC_I_TIME DOUBLE PRECISION :: ACC_FAC_MQ_TIME DOUBLE PRECISION :: ACC_FAC_SQ_TIME DOUBLE PRECISION :: ACC_FRFRONTS_TIME DOUBLE PRECISION :: AVG_ACC_FLOP_LR_FACTO DOUBLE PRECISION :: MIN_ACC_FLOP_LR_FACTO DOUBLE PRECISION :: MAX_ACC_FLOP_LR_FACTO 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 INTEGER, POINTER :: STEP_STATS(:) 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 UPDATE_ALL_TIMES(INODE, LOC_FACTO_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_FACTO_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_FRFRONTS_TIME, LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME ACC_UPDT_TIME = ACC_UPDT_TIME + LOC_FACTO_TIME ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + LOC_PROMOTING_TIME ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + LOC_DEMOTING_TIME ACC_CB_DEMOTING_TIME = ACC_CB_DEMOTING_TIME + & LOC_CB_DEMOTING_TIME ACC_FRPANELS_TIME = ACC_FRPANELS_TIME + LOC_FRPANELS_TIME ACC_FAC_I_TIME = ACC_FAC_I_TIME + LOC_FAC_I_TIME ACC_FAC_MQ_TIME = ACC_FAC_MQ_TIME + LOC_FAC_MQ_TIME ACC_FAC_SQ_TIME = ACC_FAC_SQ_TIME + LOC_FAC_SQ_TIME ACC_FRFRONTS_TIME = ACC_FRFRONTS_TIME + LOC_FRFRONTS_TIME ACC_TRSM_TIME = ACC_TRSM_TIME + LOC_TRSM_TIME ACC_LR_MODULE_TIME = ACC_LR_MODULE_TIME + LOC_LR_MODULE_TIME END SUBROUTINE UPDATE_ALL_TIMES SUBROUTINE UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_CB_DEMOTING_TIME ACC_CB_DEMOTING_TIME = ACC_CB_DEMOTING_TIME + & LOC_CB_DEMOTING_TIME END SUBROUTINE UPDATE_CB_DEMOTING_TIME SUBROUTINE UPDATE_UPDT_TIME(INODE, LOC_UPDT_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_UPDT_TIME ACC_UPDT_TIME = ACC_UPDT_TIME + LOC_UPDT_TIME END SUBROUTINE UPDATE_UPDT_TIME SUBROUTINE UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) DOUBLE PRECISION, INTENT(IN) :: LOC_UPDT_TIME_OUT ACC_UPDT_TIME_OUT = ACC_UPDT_TIME_OUT + LOC_UPDT_TIME_OUT END SUBROUTINE UPDATE_UPDT_TIME_OUT SUBROUTINE UPDATE_RMB_TIME(LOC_RMB_TIME) DOUBLE PRECISION, INTENT(IN) :: LOC_RMB_TIME ACC_RMB_TIME = ACC_RMB_TIME + LOC_RMB_TIME END SUBROUTINE UPDATE_RMB_TIME SUBROUTINE UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_PROMOTING_TIME ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & LOC_PROMOTING_TIME END SUBROUTINE UPDATE_PROMOTING_TIME SUBROUTINE UPDATE_FLOP_STATS_CB_PROMOTE(COST, NIV) DOUBLE PRECISION :: COST INTEGER :: NIV IF (NIV.EQ.1) THEN !$OMP CRITICAL(cb_flop_cost_pro_cri) FLOP_CB_PROMOTE = FLOP_CB_PROMOTE + COST !$OMP END CRITICAL(cb_flop_cost_pro_cri) ELSE !$OMP CRITICAL(acc_cb_flop_cost_pro_cri) ACC_FLOP_CB_PROMOTE = ACC_FLOP_CB_PROMOTE + COST !$OMP END CRITICAL(acc_cb_flop_cost_pro_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_CB_PROMOTE SUBROUTINE UPDATE_FLOP_STATS_CB_DEMOTE(COST, NIV) DOUBLE PRECISION :: COST INTEGER :: NIV IF (NIV.EQ.1) THEN !$OMP CRITICAL(cb_flop_cost_dem_cri) FLOP_CB_DEMOTE = FLOP_CB_DEMOTE + COST !$OMP END CRITICAL(cb_flop_cost_dem_cri) ELSE !$OMP CRITICAL(acc_cb_flop_cost_dem_cri) ACC_FLOP_CB_DEMOTE = ACC_FLOP_CB_DEMOTE + COST !$OMP END CRITICAL(acc_cb_flop_cost_dem_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_CB_DEMOTE SUBROUTINE UPDATE_FLOP_STATS_DEMOTE(LR_B, NIV, REC_ACC) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER(8) :: M,N,K INTEGER :: NIV DOUBLE PRECISION :: HR_COST,BUILDQ_COST LOGICAL, OPTIONAL :: REC_ACC M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K,8) HR_COST = dble(4_8*K*K*K/3_8 + 4_8*K*M*N - 2_8*(M+N)*K*K) IF (LR_B%ISLR) THEN BUILDQ_COST = dble(4_8*K*K*M - K*K*K) ELSE BUILDQ_COST = 0.0d0 END IF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_DEMOTE = FLOP_DEMOTE + HR_COST + BUILDQ_COST IF (present(REC_ACC)) THEN IF (REC_ACC) THEN FLOP_REC_ACC = FLOP_REC_ACC + HR_COST+BUILDQ_COST ENDIF ENDIF !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + (HR_COST + BUILDQ_COST) IF (present(REC_ACC)) THEN IF (REC_ACC) THEN ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC +HR_COST+BUILDQ_COST ENDIF ENDIF !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_DEMOTE SUBROUTINE UPDATE_FLOP_STATS_REC_ACC(LR_B, NIV, K1, K2, BUILDQ1) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER,INTENT(IN) :: NIV, K1, K2 LOGICAL,INTENT(IN) :: BUILDQ1 INTEGER(8) :: M,N,K DOUBLE PRECISION :: HR_COST, BUILDQ_COST, GS_COST, UPDT_COST, & TOT_COST M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K - K1,8) GS_COST = dble((4_8*(K1)+1_8)*M*K2) HR_COST = dble(4_8*K*K*K/3_8 + 4_8*K*M*K2 - 2_8*(M+K2)*K*K) IF (BUILDQ1) THEN BUILDQ_COST = dble(4_8*K*K*M - K*K*K) UPDT_COST = dble(2_8*K*K2*N) ELSE BUILDQ_COST = 0.0d0 UPDT_COST = 0.0d0 ENDIF TOT_COST = BUILDQ_COST + HR_COST + GS_COST + UPDT_COST IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_DEMOTE = FLOP_DEMOTE + TOT_COST FLOP_REC_ACC = FLOP_REC_ACC + TOT_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + TOT_COST ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + TOT_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_REC_ACC SUBROUTINE UPDATE_FLOP_STATS_PANEL(NFRONT, NPIV, NIV, SYM) INTEGER :: NFRONT, NPIV, NIV, SYM DOUBLE PRECISION :: COST_PANEL, COST_TRSM IF (SYM.EQ.0) THEN COST_TRSM = dble(2 * NPIV-1) * dble(NPIV) & * dble(NFRONT-NPIV) COST_PANEL = dble(NPIV) * dble(NPIV - 1) & * dble(4 * NPIV + 1)/dble(6) ELSE COST_TRSM = dble(NPIV) * dble(NPIV) * dble(NFRONT-NPIV) COST_PANEL = dble(NPIV) * dble(NPIV - 1) & * dble(2 * NPIV + 1)/dble(6) ENDIF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_PANEL = FLOP_PANEL + COST_PANEL FLOP_TRSM = FLOP_TRSM + COST_TRSM !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_PANEL = ACC_FLOP_PANEL + COST_PANEL ACC_FLOP_TRSM = ACC_FLOP_TRSM + COST_TRSM !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_PANEL SUBROUTINE UPDATE_FLOP_STATS_TRSM(LRB, NIV, LorU, K470) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: NIV, LorU, K470 DOUBLE PRECISION :: LR_FLOP_COST, FR_FLOP_COST IF (LorU.EQ.0) THEN FR_FLOP_COST = dble(LRB%M)*dble(LRB%N)*dble(LRB%N) IF (LRB%ISLR) THEN LR_FLOP_COST = dble(LRB%K)*dble(LRB%N)*dble(LRB%N) ELSE LR_FLOP_COST = FR_FLOP_COST ENDIF ELSE IF (K470.EQ.1) THEN FR_FLOP_COST = dble(LRB%M-1)*dble(LRB%N)*dble(LRB%N) ELSE FR_FLOP_COST = dble(LRB%M-1)*dble(LRB%M)*dble(LRB%N) ENDIF IF (LRB%ISLR) THEN IF (K470.EQ.1) THEN LR_FLOP_COST = dble(LRB%N-1)*dble(LRB%N)*dble(LRB%K) ELSE LR_FLOP_COST = dble(LRB%M-1)*dble(LRB%M)*dble(LRB%K) ENDIF ELSE LR_FLOP_COST = FR_FLOP_COST ENDIF ENDIF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_FR_TRSM = FLOP_FR_TRSM + FR_FLOP_COST FLOP_LR_TRSM = FLOP_LR_TRSM + LR_FLOP_COST LR_FLOP_GAIN = LR_FLOP_GAIN + FR_FLOP_COST & - LR_FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_FR_TRSM = ACC_FLOP_FR_TRSM + FR_FLOP_COST ACC_FLOP_LR_TRSM = ACC_FLOP_LR_TRSM + LR_FLOP_COST ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + FR_FLOP_COST & - LR_FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) END IF END SUBROUTINE UPDATE_FLOP_STATS_TRSM SUBROUTINE UPDATE_FLOP_STATS_LRB_PRODUCT(LRB1, LRB2, TRANSB1, & TRANSB2, NIV, COMPRESS_MID_PRODUCT, RANK_IN, BUILDQ, & IS_DIAG, K480, REC_ACC_IN) !$ USE OMP_LIB TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 CHARACTER(len=1), INTENT(IN) :: TRANSB1, TRANSB2 LOGICAL, INTENT(IN), OPTIONAL :: BUILDQ, IS_DIAG, REC_ACC_IN INTEGER, INTENT(IN), OPTIONAL :: NIV, RANK_IN, & COMPRESS_MID_PRODUCT, K480 LOGICAL :: REC_ACC DOUBLE PRECISION :: LR_FLOP_COST, LR_FLOP_COST_OUT, FR_FLOP_COST DOUBLE PRECISION :: HR_COST, BUILDQ_COST DOUBLE PRECISION :: M1,N1,K1,M2,N2,K2,RANK CHARACTER(len=2) :: PROD, TRANS IF(present(K480).AND.present(REC_ACC_IN)) THEN IF (K480.GE.4) THEN REC_ACC = REC_ACC_IN ELSE REC_ACC = .FALSE. ENDIF ELSE REC_ACC = .FALSE. ENDIF 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) IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) THEN PROD = '00' ELSE IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN PROD = '10' ELSE IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN PROD = '01' ELSE PROD = '11' END IF IF ((TRANSB1=='N').AND.(TRANSB2=='N')) THEN TRANS = 'NN' ELSE IF ((TRANSB1=='T').AND.(TRANSB2=='N')) THEN TRANS = 'TN' ELSE IF ((TRANSB1=='N').AND.(TRANSB2=='T')) THEN TRANS = 'NT' ELSE TRANS = 'TT' END IF LR_FLOP_COST_OUT = 0.0D0 HR_COST = 0.0D0 BUILDQ_COST = 0.0D0 SELECT CASE (PROD) CASE('00') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*M1*N2*N1 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*M1*N2*N1 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*M1*M2*N1 CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 LR_FLOP_COST = 2.0D0*N1*M2*M1 END SELECT CASE('10') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*K1*N2*N1 + 2.0D0*M1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K1 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*K1*N2*M1 + 2.0D0*N1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K1 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*K1*M2*N1 + 2.0D0*M1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K1 CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 LR_FLOP_COST = 2.0D0*K1*M2*M1 + 2.0D0*N1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K1 END SELECT CASE('01') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*M1*K2*N1 + 2.0D0*M1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K2 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*N1*K2*M1 + 2.0D0*N1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K2 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*M1*K2*N1 + 2.0D0*M1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K2 CASE('TT') FR_FLOP_COST = 2*N1*M2*M1 LR_FLOP_COST = 2.0D0*N1*K2*M1 + 2.0D0*N1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K2 END SELECT CASE('11') IF (COMPRESS_MID_PRODUCT.GE.1) THEN HR_COST = 4.0D0*RANK*RANK*RANK/3.0D0 + & 4.0D0*RANK*K1*K2 - & 2.0D0*(K1+K2)*RANK*RANK IF (BUILDQ) THEN BUILDQ_COST = 4.0D0*RANK*RANK*K1 - RANK*RANK*RANK ENDIF ENDIF SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*RANK + 2.0D0*K2*N2*RANK + & 2.0D0*M1*N2*RANK LR_FLOP_COST_OUT = 2.0D0*M1*N2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*K2 + 2.0D0*M1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*N2*K2 + 2.0D0*M1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K1 ENDIF ENDIF CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*RANK + 2.0D0*K2*N2*RANK + & 2.0D0*N1*N2*RANK LR_FLOP_COST_OUT = 2.0D0*N1*N2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*K2 + 2.0D0*N1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N2*K2 + 2.0D0*N1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K1 ENDIF ENDIF CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*RANK + 2.0D0*K2*M2*RANK + & 2.0D0*M1*M2*RANK LR_FLOP_COST_OUT = 2.0D0*M1*M2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*K2 + 2.0D0*M1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M2*K2 + 2.0D0*M1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K1 ENDIF ENDIF CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*RANK + 2.0D0*K2*M2*RANK + & 2.0D0*N1*M2*RANK LR_FLOP_COST_OUT = 2.0D0*N1*M2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*K2 + 2.0D0*N1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*M2*K2 + 2.0D0*N1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K1 ENDIF ENDIF END SELECT END SELECT IF (present(IS_DIAG)) THEN IF (IS_DIAG) THEN FR_FLOP_COST = FR_FLOP_COST/2.0D0 LR_FLOP_COST = LR_FLOP_COST/2.0D0 ENDIF ENDIF IF (present(K480)) THEN IF (K480.GE.3) THEN LR_FLOP_COST = LR_FLOP_COST - LR_FLOP_COST_OUT LR_FLOP_COST_OUT = 0.0D0 IF (REC_ACC) THEN IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_REC_ACC = FLOP_REC_ACC + LR_FLOP_COST & + HR_COST + BUILDQ_COST FLOP_DEMOTE = FLOP_DEMOTE + LR_FLOP_COST & + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + LR_FLOP_COST & + HR_COST + BUILDQ_COST ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + LR_FLOP_COST & + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF ENDIF ENDIF ENDIF IF (.NOT.REC_ACC) THEN IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) LR_FLOP_GAIN = LR_FLOP_GAIN + FR_FLOP_COST - LR_FLOP_COST FLOP_FR_UPDT = FLOP_FR_UPDT + FR_FLOP_COST FLOP_LR_UPDT = FLOP_LR_UPDT + LR_FLOP_COST FLOP_LR_UPDT_OUT = FLOP_LR_UPDT_OUT + LR_FLOP_COST_OUT FLOP_DEMOTE = FLOP_DEMOTE + HR_COST + BUILDQ_COST FLOP_RMB = FLOP_RMB + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + & FR_FLOP_COST - LR_FLOP_COST ACC_FLOP_FR_UPDT = ACC_FLOP_FR_UPDT + FR_FLOP_COST ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + LR_FLOP_COST ACC_FLOP_LR_UPDT_OUT = ACC_FLOP_LR_UPDT_OUT + & LR_FLOP_COST_OUT ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + HR_COST + BUILDQ_COST ACC_FLOP_RMB = ACC_FLOP_RMB + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF ENDIF END SUBROUTINE UPDATE_FLOP_STATS_LRB_PRODUCT SUBROUTINE UPDATE_FLOP_STATS_DEC_ACC(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) IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) LR_FLOP_GAIN = LR_FLOP_GAIN - FLOP_COST FLOP_LR_UPDT = FLOP_LR_UPDT + FLOP_COST FLOP_LR_UPDT_OUT = FLOP_LR_UPDT_OUT + FLOP_COST FLOP_DEC_ACC = FLOP_DEC_ACC + FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN - FLOP_COST ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + FLOP_COST ACC_FLOP_LR_UPDT_OUT = ACC_FLOP_LR_UPDT_OUT + & FLOP_COST ACC_FLOP_DEC_ACC = ACC_FLOP_DEC_ACC + FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_DEC_ACC SUBROUTINE UPDATE_FLOPS_STATS_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)) ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + COST_PER_PROC RETURN END SUBROUTINE UPDATE_FLOPS_STATS_ROOT SUBROUTINE INIT_STATS_FRONT(NFRONT,INODE,NASS,NCB) INTEGER,INTENT(IN) :: NFRONT,INODE,NASS,NCB FRONT_L11_BLR_SAVINGS = 0.D0 FRONT_U11_BLR_SAVINGS = 0.D0 FRONT_L21_BLR_SAVINGS = 0.D0 FRONT_U12_BLR_SAVINGS = 0.D0 LR_FLOP_GAIN = 0.D0 FLOP_CB_DEMOTE = 0.D0 FLOP_CB_PROMOTE = 0.D0 FLOP_FR_UPDT = 0.D0 FLOP_LR_UPDT = 0.D0 FLOP_LR_UPDT_OUT = 0.D0 FLOP_RMB = 0.D0 FLOP_FR_TRSM = 0.D0 FLOP_LR_TRSM = 0.D0 FLOP_DEMOTE = 0.D0 FLOP_DEC_ACC = 0.D0 FLOP_REC_ACC = 0.D0 FLOP_PANEL = 0.D0 FLOP_TRSM = 0.D0 END SUBROUTINE INIT_STATS_FRONT SUBROUTINE INIT_STATS_GLOBAL(id) use CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET :: id ACC_MRY_CB_GAIN = 0.D0 ACC_MRY_CB_FR = 0.D0 ACC_FLOP_CB_DEMOTE = 0.D0 ACC_FLOP_CB_PROMOTE = 0.D0 ACC_FLOP_FR_FACTO = 0.D0 ACC_FLOP_LR_FACTO = 0.D0 ACC_FLOP_FR_UPDT = 0.D0 ACC_FLOP_LR_UPDT = 0.D0 ACC_FLOP_LR_UPDT_OUT = 0.D0 ACC_FLOP_RMB = 0.D0 ACC_FLOP_FR_TRSM = 0.D0 ACC_FLOP_LR_TRSM = 0.D0 ACC_FLOP_DEMOTE = 0.D0 ACC_FLOP_TRSM = 0.D0 ACC_FLOP_DEC_ACC = 0.D0 ACC_FLOP_REC_ACC = 0.D0 ACC_FLOP_PANEL = 0.D0 ACC_FLOP_FRFRONTS = 0.D0 ACC_FLOP_FR_SOLVE = 0.D0 ACC_FLOP_LR_SOLVE = 0.D0 ACC_LR_FLOP_GAIN = 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 ACC_FR_MRY = 0.D0 GLOBAL_BLR_SAVINGS = 0.D0 ACC_UPDT_TIME = 0.D0 ACC_UPDT_TIME_OUT = 0.D0 ACC_RMB_TIME = 0.D0 ACC_PROMOTING_TIME = 0.D0 ACC_DEMOTING_TIME = 0.D0 ACC_CB_DEMOTING_TIME = 0.D0 ACC_FRPANELS_TIME = 0.0D0 ACC_FAC_I_TIME = 0.0D0 ACC_FAC_MQ_TIME = 0.0D0 ACC_FAC_SQ_TIME = 0.0D0 ACC_FRFRONTS_TIME = 0.0D0 ACC_TRSM_TIME = 0.D0 ACC_LR_MODULE_TIME = 0.D0 CNT_NODES = 0 STEP_STATS => id%STEP END SUBROUTINE INIT_STATS_GLOBAL SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NCB, & SYM, INODE, NELIM) INTEGER,INTENT(IN) :: NASS, NCB, SYM, INODE, NELIM DOUBLE PRECISION :: FRONT_BLR_SAVINGS, FRONT_FR_MRY IF (SYM .GT. 0) THEN FRONT_BLR_SAVINGS = FRONT_L11_BLR_SAVINGS & + FRONT_L21_BLR_SAVINGS FRONT_FR_MRY = dble(NASS-NELIM) * & (dble(NASS-NELIM)+1.D0)/2.D0 & + dble(NASS-NELIM) * dble(NCB+NELIM) ELSE FRONT_BLR_SAVINGS = FRONT_L11_BLR_SAVINGS & + FRONT_L21_BLR_SAVINGS & + FRONT_U11_BLR_SAVINGS & + FRONT_U12_BLR_SAVINGS FRONT_FR_MRY = dble(NASS-NELIM) * dble(NASS-NELIM) & + 2.0D0 * dble(NASS-NELIM) * dble(NCB+NELIM) END IF ACC_FR_MRY = ACC_FR_MRY + FRONT_FR_MRY GLOBAL_BLR_SAVINGS = GLOBAL_BLR_SAVINGS + FRONT_BLR_SAVINGS END SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE1 SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, & SYM, INODE, NELIM) INTEGER,INTENT(IN) :: NASS, NFRONT, SYM, INODE, NELIM IF (SYM .GT. 0) THEN ACC_FR_MRY = ACC_FR_MRY + & dble(NASS-NELIM) * & (dble(NASS-NELIM)+1.D0)/2.D0 & + dble(NASS-NELIM) * dble(NFRONT-NASS+NELIM) ELSE ACC_FR_MRY = ACC_FR_MRY + & dble(NASS-NELIM) * dble(NASS-NELIM) & + 2.0D0 * dble(NASS-NELIM) * dble(NFRONT-NASS+NELIM) ENDIF END SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE2 SUBROUTINE STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, & SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS) INTEGER,INTENT(IN) :: NROW, NCB, SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS DOUBLE PRECISION :: MRY_CB_FR IF (SYM==0) THEN MRY_CB_FR = dble(NCB)*dble(NROW) ELSE MRY_CB_FR = dble(NCB-NROW)*dble(NROW) + & dble(NROW)*dble(NROW+1)/2.D0 ENDIF ACC_MRY_CB_FR = ACC_MRY_CB_FR + MRY_CB_FR ACC_MRY_CB_GAIN = ACC_MRY_CB_GAIN + FRONT_CB_BLR_SAVINGS END SUBROUTINE STATS_COMPUTE_MRY_FRONT_CB SUBROUTINE STATS_STORE_BLR_PANEL_MRY(BLR_PANEL, NB_INASM, & NB_INCB, DIR, NIV) INTEGER,INTENT(IN) :: NB_INASM, NB_INCB, NIV TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(NB_INASM+NB_INCB) CHARACTER(len=1) :: DIR INTEGER :: I IF (NB_INASM.GT.0.AND.DIR .EQ.'V') THEN ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + & dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N) ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N) ENDIF DO I = 1 , NB_INASM ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + & dble(2)*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) IF (BLR_PANEL(I)%ISLR) THEN ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(4)*(dble(BLR_PANEL(I)%M)+dble(BLR_PANEL(I)%N))* & dble(BLR_PANEL(I)%K) IF (DIR .EQ. 'H') THEN IF (NIV .EQ. 1) THEN FRONT_U11_BLR_SAVINGS = & FRONT_U11_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ELSE IF (NIV .EQ. 1) THEN FRONT_L11_BLR_SAVINGS = & FRONT_L11_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M) + dble(BLR_PANEL(I)%N ) ENDIF ENDIF ELSE ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(2)*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) ENDIF END DO DO I = NB_INASM + 1 , NB_INASM + NB_INCB IF (BLR_PANEL(I)%ISLR) THEN IF (DIR .EQ. 'H') THEN IF (NIV .EQ. 1) THEN FRONT_U12_BLR_SAVINGS = & FRONT_U12_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ELSE IF (NIV .EQ. 1) THEN FRONT_L21_BLR_SAVINGS = & FRONT_L21_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble ( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ENDIF END IF END DO END SUBROUTINE STATS_STORE_BLR_PANEL_MRY SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE1( NFRONT, NASS, NPIV, & KEEP50, INODE) INTEGER,INTENT(IN) :: NFRONT, KEEP50, NASS, NPIV, INODE DOUBLE PRECISION :: FLOP_FR_FACTO CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & KEEP50, 1, FLOP_FR_FACTO) ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + LR_FLOP_GAIN ACC_FLOP_FR_UPDT = ACC_FLOP_FR_UPDT + FLOP_FR_UPDT ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + FLOP_LR_UPDT ACC_FLOP_LR_UPDT_OUT= ACC_FLOP_LR_UPDT_OUT+ FLOP_LR_UPDT_OUT ACC_FLOP_RMB = ACC_FLOP_RMB + FLOP_RMB ACC_FLOP_FR_TRSM = ACC_FLOP_FR_TRSM + FLOP_FR_TRSM ACC_FLOP_LR_TRSM = ACC_FLOP_LR_TRSM + FLOP_LR_TRSM ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + FLOP_DEMOTE ACC_FLOP_CB_DEMOTE = ACC_FLOP_CB_DEMOTE + FLOP_CB_DEMOTE ACC_FLOP_CB_PROMOTE = ACC_FLOP_CB_PROMOTE + FLOP_CB_PROMOTE ACC_FLOP_DEC_ACC = ACC_FLOP_DEC_ACC + FLOP_DEC_ACC ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + FLOP_REC_ACC ACC_FLOP_TRSM = ACC_FLOP_TRSM + FLOP_TRSM ACC_FLOP_PANEL = ACC_FLOP_PANEL + FLOP_PANEL END SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE1 SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE2( NFRONT, NASS, & KEEP50, INODE, NELIM) INTEGER,INTENT(IN) :: NFRONT, KEEP50, NASS, INODE, NELIM DOUBLE PRECISION :: FLOP_FR_FACTO CALL MUMPS_GET_FLOPS_COST(NFRONT, NASS-NELIM, NASS, & KEEP50, 2, FLOP_FR_FACTO) ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO END SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE2 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_FR_FACTO NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP_FR_FACTO = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP_FR_FACTO = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO END SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2 SUBROUTINE UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, SYM, & NIV) INTEGER, INTENT(IN) :: NFRONT, NPIV, NASS, SYM, NIV DOUBLE PRECISION :: FLOP_FRFRONTS, FLOP_SOLVE CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP_FRFRONTS) ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + FLOP_FRFRONTS FLOP_SOLVE = dble(NASS)*dble(NASS) + & dble(NFRONT-NASS)*dble(NASS) IF (SYM.EQ.0) FLOP_SOLVE = 2.0D0*FLOP_SOLVE ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + FLOP_SOLVE ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + FLOP_SOLVE END SUBROUTINE UPDATE_FLOP_STATS_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_FRFRONTS NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP_FRFRONTS = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP_FRFRONTS = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + FLOP_FRFRONTS END SUBROUTINE UPD_FLOP_FRFRONT_SLAVE SUBROUTINE COMPUTE_GLOBAL_GAINS(NB_ENTRIES_FACTOR, & FLOP_NUMBER, NIV, PROKG, MPG) INTEGER(KIND=8), INTENT(IN) :: NB_ENTRIES_FACTOR INTEGER, INTENT(IN) :: NIV, MPG LOGICAL, INTENT(IN) :: PROKG REAL , INTENT(IN) :: FLOP_NUMBER 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 (ACC_FR_MRY .EQ. 0) THEN GLOBAL_MRY_LPRO_COMPR = 100.0D0 ELSE GLOBAL_MRY_LPRO_COMPR = 100.0D0 * & GLOBAL_BLR_SAVINGS/ACC_FR_MRY ENDIF IF (ACC_MRY_CB_FR .EQ. 0) THEN ACC_MRY_CB_FR = 100.0D0 END IF IF (NB_ENTRIES_FACTOR.EQ.0) THEN FACTOR_PROCESSED_FRACTION = 100.0D0 GLOBAL_MRY_LTOT_COMPR = 100.0D0 ELSE FACTOR_PROCESSED_FRACTION = 100.0D0 * & ACC_FR_MRY/dble(NB_ENTRIES_FACTOR) GLOBAL_MRY_LTOT_COMPR = & 100.0D0*GLOBAL_BLR_SAVINGS/dble(NB_ENTRIES_FACTOR) ENDIF TOTAL_FLOP = FLOP_NUMBER ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN & + ACC_FLOP_DEMOTE RETURN END SUBROUTINE COMPUTE_GLOBAL_GAINS SUBROUTINE SAVEandWRITE_GAINS(LOCAL, K489, DKEEP, N, & DEPTH, BCKSZ, NASSMIN, NFRONTMIN, SYM, K486, & K472, K475, K478, K480, K481, K483, K484, K485, K467, & NBTREENODES, NPROCS, MPG, PROKG) INTEGER, INTENT(IN) :: LOCAL,K489,N,DEPTH,BCKSZ,NASSMIN, & NFRONTMIN, K486, NBTREENODES, MPG, K467, & K472, K475, K478, K480, K481, K483, K484, K485, SYM, NPROCS 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)') & ' Settings for Block Low-Rank (BLR) are :' WRITE(MPG,'(A)') ' BLR algorithm characteristics :' WRITE(MPG,'(A,A)') ' Variant used: FSCU ', & '(Factor-Solve-Compress-Update)' SELECT CASE (K489) CASE (0) CASE (1) WRITE(MPG,'(A)') & ' Experimental CB compression (for stats only)' CASE DEFAULT WRITE(*,*)' Internal error K489=',K489 CALL MUMPS_ABORT() END SELECT IF (K472.EQ.0) THEN WRITE(MPG,'(A,A,I4)') ' Target BLR block size (fixed)', & ' =', & BCKSZ ELSE WRITE(MPG,'(A,A,I4,A,I4)') & ' Target BLR block size (variable)', & ' =', & 128, ' -', BCKSZ ENDIF WRITE(MPG,'(A,A,ES8.1)') ' RRQR precision (epsilon) ', & ' =', & 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)') & ' 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(ACC_FLOP_LR_FACTO+ACC_FLOP_FRFRONTS) DKEEP(61)=real(100*(ACC_FLOP_LR_FACTO+ & ACC_FLOP_FRFRONTS) /TOTAL_FLOP) IF (PROK) THEN WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' Total theoretical full-rank OPC (i.e. FR OPC) =' & ,TOTAL_FLOP,' (',100*TOTAL_FLOP/TOTAL_FLOP,'%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' Total effective OPC (% FR OPC) =' & ,ACC_FLOP_LR_FACTO+ACC_FLOP_FRFRONTS,' (' &,100*(ACC_FLOP_LR_FACTO+ACC_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.1.2/src/dfac_lr.F0000664000175000017500000010656313164366264015242 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE DMUMPS_FAC_LR USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_ANA_LR 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, & COMPRESS_MID_PRODUCT, TOLEPS, 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 INTEGER, intent(out) :: IFLAG, IERROR DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR-CURRENT_BLR) DOUBLE PRECISION, INTENT(INOUT), TARGET :: BLOCK(:,:) INTEGER, intent(in) :: IW2(*) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK DOUBLE PRECISION, POINTER, DIMENSION(:) :: BLOCK_PTR 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 BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,1) #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, BLOCK_PTR, !$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 = OMP_GET_THREAD_NUM() BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1) #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL DMUMPS_LRGEMM3('N', 'T', MONE, & BLR_L(J),BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, NFRONT, & IW2, & BLOCK_PTR, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_L(J), BLR_L(I), 'N', & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ & , (I.EQ.J) & ) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE DMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, POSBLOCFACTO, 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, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, POSBLOCFACTO DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(out) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), & 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, POINTER, 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) :: COMPRESS_MID_PRODUCT, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ 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 = POSBLOCFACTO #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, 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 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_LRGEMM3('N', 'T', MONE, & BLR_LM(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, 2, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, LD_BLOCFACTO, & IW2, & BLOCK, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LM(J), BLR_LS(I), & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, & .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, 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 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_LRGEMM3('N', 'T', MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, 2, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT, & MID_RANK, BUILDQ, & POSELTD, LD_BLOCFACTO, & IW2, & BLOCK, & MAXI_CLUSTER) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LS(J), BLR_LS(I), & 'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ, & (I.EQ.J)) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE DMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT SUBROUTINE DMUMPS_BLR_UPDATE_NELIM_VAR( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, CURRENT_BLR, & NELIM, SYM, NIV, FIRST_BLOCK LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(out) :: IFLAG, IERROR INTEGER, intent(in) :: ISHIFT DOUBLE PRECISION, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL, IS INTEGER :: allocok 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 IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if defined(BLR_MT) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = FIRST_BLOCK-CURRENT_BLR, 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 write(*,*) 'Allocation problem in BLR routine & DMUMPS_BLR_UPDATE_NELIM_VAR: ', & 'not enough memory? memory requested = ', IERROR 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 IF (SYM.EQ.0) THEN 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) ELSE POSELT_TOP = POSELT + int(NFRONT,8) & * int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) & + int((BEGS_BLR_L(CURRENT_BLR)-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('T' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDIF ENDDO ENDIF 100 CONTINUE #if defined(BLR_MT) !$OMP END SINGLE #endif END SUBROUTINE DMUMPS_BLR_UPDATE_NELIM_VAR 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, K470, & COMPRESS_MID_PRODUCT, TOLEPS, 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, K470, & NELIM, NIV, SYM INTEGER, intent(out) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT DOUBLE PRECISION, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, 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 CHARACTER(len=1) :: TRANSB1 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 write(*,*) 'Allocation problem in BLR routine & DMUMPS_BLR_UPDATE_TRAILING: ', & 'not enough memory? memory requested = ', IERROR 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) IF (SYM.EQ.0) THEN IF (K470.EQ.1) THEN TRANSB1 = 'N' ELSE TRANSB1 = 'T' ENDIF CALL DMUMPS_LRGEMM3(TRANSB1, 'T', MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, & KPERCENT, MID_RANK, BUILDQ) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), & TRANSB1, & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) ELSE CALL DMUMPS_LRGEMM3('N', 'T', MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, NIV, IFLAG, IERROR, & COMPRESS_MID_PRODUCT, TOLEPS, & KPERCENT, MID_RANK, BUILDQ) IF (IFLAG.LT.0) CYCLE CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), 'N', & 'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ) ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING SUBROUTINE DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & LD_OR_NPIV, K470, & BEG_I_IN, END_I_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) :: NFRONT, 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) :: LD_OR_NPIV, K470 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN INTEGER :: IP, M, N, BIP, BEG_I, END_I #if defined(BLR_MT) INTEGER :: LAST_IP, CHUNK #endif INTEGER :: K, I INTEGER(8) :: POSELT_BLOCK, NFRONT8, 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 NFRONT8 = int(NFRONT,8) LD_BLK_IN_FRONT = NFRONT8 BIP = BEGS_BLR_FIRST_OFFDIAG #if defined(BLR_MT) LAST_IP = BEG_I CHUNK = 1 !$OMP PARALLEL DO PRIVATE(POSELT_BLOCK, M, N, K, I) !$OMP& FIRSTPRIVATE(BIP, LAST_IP) SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if defined(BLR_MT) DO I = 1, IP - LAST_IP IF (DIR .eq. 'V') THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ELSE IF (K470.EQ.1) THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ELSE BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N ENDIF ENDIF ENDDO LAST_IP = IP #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LD_OR_NPIV) THEN POSELT_BLOCK = POSELT + NFRONT8*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ELSE POSELT_BLOCK = POSELT +NFRONT8*int(LD_OR_NPIV,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LD_OR_NPIV,8)*int(BIP-1-LD_OR_NPIV,8) LD_BLK_IN_FRONT=int(LD_OR_NPIV,8) ENDIF ELSE POSELT_BLOCK = POSELT + & NFRONT8*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 K = BLR_PANEL(IP-CURRENT_BLR)%K IF ((BLR_PANEL(IP-CURRENT_BLR)%ISLR).AND. & (BLR_PANEL(IP-CURRENT_BLR)%LRFORM.EQ.1)) THEN IF (K.EQ.0) THEN IF (K470.NE.1.OR.DIR .eq. 'V') THEN DO I = 1, M 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 = 1, N A(POSELT_BLOCK+int(I-1,8)*NFRONT8: & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (K470.NE.1.OR.DIR .eq. 'V') THEN 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)) ELSE CALL dgemm('N', 'N', M, N, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & ZERO, A(POSELT_BLOCK), NFRONT) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (K470.NE.1.OR.DIR .eq. 'V') THEN DO I = 1, M 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 = 1, N A(POSELT_BLOCK+int(I-1,8)*NFRONT8: & POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if !defined(BLR_MT) IF (DIR .eq. 'V') THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ELSE IF (K470.EQ.1) THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ELSE BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%N ENDIF ENDIF #endif END DO #if defined(BLR_MT) !$OMP END PARALLEL DO #endif END SUBROUTINE DMUMPS_DECOMPRESS_PANEL SUBROUTINE DMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR_L, NB_BLR_L, & BEGS_BLR_U, NB_BLR_U, NPARTSASS_U, & TOLEPS, NASS, NROW, & SYM, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, INODE, NIV, & LBANDSLAVE, ISHIFT,KPERCENT) INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, INODE INTEGER, INTENT(IN) :: NIV, NROW, KPERCENT INTEGER :: MAXI_CLUSTER, LWORK, SYM, NASS, & NB_BLR_L, NB_BLR_U, NPARTSASS_U DOUBLE PRECISION,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U DOUBLE PRECISION :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER) DOUBLE PRECISION,DIMENSION(:) :: RWORK DOUBLE PRECISION, DIMENSION(:) :: WORK, TAU INTEGER, DIMENSION(:) :: JPVT INTEGER :: M, N, NCB, BEGLOOP, RANK, MAXRANK, FRONT_CB_BLR_SAVINGS INTEGER :: INFO, I, J, JJ, IB, JDEB, IS INTEGER :: allocok, MREQ INTEGER(8) :: POSELT_BLOCK DOUBLE PRECISION :: HR_COST, BUILDQ_COST, CB_DEMOTE_COST, & CB_PROMOTE_COST INTEGER T1, T2, COUNT_RATE DOUBLE PRECISION :: LOC_PROMOTING_TIME DOUBLE PRECISION :: LOC_CB_DEMOTING_TIME DOUBLE PRECISION, ALLOCATABLE :: R(:,:) DOUBLE PRECISION :: ONE, ZERO PARAMETER (ONE = 1.0D0) PARAMETER (ZERO = 0.0D0) LOC_PROMOTING_TIME = 0.0D0 LOC_CB_DEMOTING_TIME = 0.0D0 CB_DEMOTE_COST = 0.0D0 CB_PROMOTE_COST = 0.0D0 allocate(R(MAXI_CLUSTER,MAXI_CLUSTER),stat=allocok) IF (allocok .GT. 0) THEN MREQ=MAXI_CLUSTER*MAXI_CLUSTER write(*,*) 'Allocation problem in BLR routine & DMUMPS_FAKE_COMPRESS_CB: ', & 'not enough memory? memory requested = ', MREQ CALL MUMPS_ABORT() ENDIF FRONT_CB_BLR_SAVINGS = 0 NCB = NFRONT - NASS IF (NCB.LE.0) RETURN IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF DO J = NPARTSASS_U+1, NB_BLR_U IF (NIV.EQ.1) THEN IF (SYM.GT.0) THEN BEGLOOP = J ELSE BEGLOOP = NPARTSASS_U + 1 ENDIF ELSE BEGLOOP = 2 ENDIF IF ((BEGS_BLR_U(J+1)+IS).LE.NASS+1) CYCLE JDEB = max(BEGS_BLR_U(J)+IS,NASS+1) N = BEGS_BLR_U(J+1)+IS-JDEB DO I = BEGLOOP, NB_BLR_L CALL SYSTEM_CLOCK(T1) JPVT = 0 M = BEGS_BLR_L(I+1)-BEGS_BLR_L(I) POSELT_BLOCK = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(I)-1),8) & + int(JDEB - 1,8) DO IB=1,M IF((I.EQ.J).AND.(SYM.GT.0).AND.(NIV.EQ.1)) THEN BLOCK(IB,1:IB) = & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : & POSELT_BLOCK+ & int((IB-1),8)*int(NFRONT,8)+int(IB-1,8) ) BLOCK(1:IB-1,IB) = BLOCK(IB,1:IB-1) ELSE BLOCK(IB,1:N) = & A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8)+int(N-1,8) ) ENDIF END DO MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL DMUMPS_TRUNCATED_RRQR( M, N, BLOCK(1,1), & MAXI_CLUSTER, JPVT(1), TAU(1), WORK(1), N, & RWORK(1), TOLEPS, RANK, MAXRANK, INFO ) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_CB_DEMOTING_TIME = LOC_CB_DEMOTING_TIME & + DBLE(T2-T1)/DBLE(COUNT_RATE) IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK & IN CB (FAKE COMPRESSION anyway) " CALL MUMPS_ABORT() END IF HR_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(RANK)/3.0D0 & + 4.0D0*dble(RANK)*dble(M)*dble(N) & - 2.0D0*dble((M+N))*dble(RANK)*dble(RANK) IF (RANK.LE.MAXRANK) THEN CALL SYSTEM_CLOCK(T1) DO JJ=1, N R(1:MIN(RANK,JJ),JPVT(JJ)) = & BLOCK(1:MIN(RANK,JJ),JJ) IF(JJ.LT.RANK) R(MIN(RANK,JJ)+1: & RANK,JPVT(JJ))= ZERO END DO CALL dorgqr(M, RANK, RANK, & BLOCK(1,1), MAXI_CLUSTER, & TAU(1), WORK(1), LWORK, INFO) CALL dgemm('T', 'T', N, M, RANK, ONE , & R , MAXI_CLUSTER, & BLOCK(1,1) , MAXI_CLUSTER, & ZERO, A(POSELT_BLOCK), NFRONT) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) BUILDQ_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(M) & - dble(RANK)*dble(RANK)*dble(RANK) & CB_DEMOTE_COST = CB_DEMOTE_COST + & (HR_COST+BUILDQ_COST) CB_PROMOTE_COST = CB_PROMOTE_COST + & 2.0D0*dble(RANK)*dble(M)*dble(N) FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & (M-RANK)*(N-RANK)-RANK*RANK ELSE CB_DEMOTE_COST = CB_DEMOTE_COST + HR_COST END IF END DO END DO deallocate(R) CALL STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS) CALL UPDATE_FLOP_STATS_CB_DEMOTE(CB_DEMOTE_COST, NIV) CALL UPDATE_FLOP_STATS_CB_PROMOTE(CB_PROMOTE_COST, NIV) CALL UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME) CALL UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME) END SUBROUTINE DMUMPS_FAKE_COMPRESS_CB SUBROUTINE DMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, K473, BLR_PANEL, CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & K470, KEEP8, K480, & 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, CURRENT_BLR, NIV INTEGER, intent(out) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK DOUBLE PRECISION, TARGET, DIMENSION(:,:) :: BLOCK DOUBLE PRECISION, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER, POINTER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, K470 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 IF (K470.EQ.1) THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE M = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF 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 = 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 (DIR .eq. 'V') THEN M = BEGS_BLR(IP+1)-BEGS_BLR(IP) POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE IF (K470.EQ.1) THEN M = BEGS_BLR(IP+1)-BEGS_BLR(IP) ELSE N = BEGS_BLR(IP+1)-BEGS_BLR(IP) ENDIF POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) END IF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF IF (K470.NE.1.OR.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, 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, RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE BLR_PANEL(IP-CURRENT_BLR)%Q = ZERO DO I=1,RANK BLR_PANEL(IP-CURRENT_BLR)%Q(I,I) = ONE END DO CALL dormqr & ('L', 'N', M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), & M, WORK_THR(1), LWORK, INFO ) IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNMQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF 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 UPDATE_FLOP_STATS_DEMOTE( & BLR_PANEL(IP-CURRENT_BLR), NIV) END IF ELSE IF (K470.NE.1.OR.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 CALL UPDATE_FLOP_STATS_DEMOTE(BLR_PANEL(IP-CURRENT_BLR), & NIV) ENDIF BLR_PANEL(IP-CURRENT_BLR)%K = -1 END IF END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE DMUMPS_COMPRESS_PANEL END MODULE DMUMPS_FAC_LR MUMPS_5.1.2/src/zini_defaults.F0000664000175000017500000013472413164366266016512 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 SIZE_INT, SIZE_REAL_OR_DOUBLE ! Type must match MUMPS_INT 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(40), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(40), INFOG(40) 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) has default value 0.01 and is used for C threshold pivoting. Values greater than 1.0 C are treated as 1.0, and less than zero as zero. 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 only used combined with null pivot row C detection (ICNTL(24) .eq. 1) and to Rank-Revealing (RR) option. C It must be set to the absolute threshold for numerical pivoting. 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 row/column C is smaller than a threshold. Let MACHEPS be the machine precision and C ||.|| be the infinite norm. C The computed threshold value for postponing pivots in case of RR on root C is stored in "SEUIL" and then "SEUIL_LDLT_NIV2" C which are identical in current version. C This absolute threshold value is stored in DKEEP(9). C C The absolute value to detect a null pivot (when ICNTL(24) .NE.0) C is stored in DKEEP(1) and must be smaller than C SEUIL when combined with RR on root. C C IF (ICNTL(16).NE.0) THEN C RR on root is active C IF (CNTL3 .LT. ZERO) THEN C SEUIL = abs(CNTL(3)) C ELSE IF (CNTL3 .GT. ZERO) THEN C SEUIL = CNTL3*ANORMINF C ELSE ! (CNTL(3) .EQ. ZERO) THEN C SEUIL = N*EPS*ANORMINF ! standard articles C ENDIF C IF (ICNTL(24).NE.0) THEN C null pivot detection C IF (CNTL(6).GT.0.AND.CNTL(6).LT.1) THEN C we want DKEEP(1) < SEUIL C DKEEP(1) = SEUIL*CNTL(6) ! ideally it could be SEUIL*CNTL(6) C ELSE C DKEEP(1) = SEUIL* 0.01D0 C ENDIF C ENDIF C C ELSE (ONLY NULL PIVOT detection is active) C we keep stratgy used in MUMPS_4.10 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 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 the row/column (except the pivot) is set to zero C and the pivot is set to 1 C Default is 0. C Note that in the symmetric parallel case, some elements of the column C are not available on the local processor and cannot be set to 0 easily. C In such cases, in the current version, C -the corresponding pivot is first set C to a large value instead of 1, even when CNTL(5) < 0. C -Updating of the off diag block is done with this large C value C -diagonal value is then reset to zero C C CNTL(6) expresses the ratio between C absolute criterion for null pivots and absolute criterion C for posponing pivots before partial pivoting analysis of pivots. C Typically C let SEUIL = F(CNTL(3)), and 0 < CNTL(6) < 1 C SEUIL is stored in DKEEP(9) C if ||Pivot row|| < SEUIL*CNTL(6) then C null pivot row detected (correct only if LDLT C for LU pivot_col must be checked too) C else if || Pivot_Row || < SEUIL then C pospone pivot C else C partial threshold pivoting C endif 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 default = 0 C else C if distributed matrix entry then C default = 7 C else C if (mc64 called or mc77 based matching) then C default=-2 and ordering is computed during analysis C else C default = 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 define 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 set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is automatically C set to 5 and ICNTL(6) is set to -2 (we need the scaling factors C 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 Authorizing extra root spliting C during analysis might be interesting C to further split the root node C (combined for example with C null pivot detection option ICNTL(24)=1 OR ICNTL(16)) 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 (or 30, or 5 depending on NSLAVES, C SYM,...) and is the value for memory relaxation C so called "PERLU" in the following. 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). 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, k=1,NRHS is C considered to be the solution corresponding to the Schur C variables. It is injected in ZMUMPS, that computes the solution C on the "internal" problem during the backward 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 performed by the solver. C Default value is -24. 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 C ICNTL(35) : Block low rank (BLR) factorization C Default value is 0 C 0 = BLR is not activated C 1 = BLR activated with grouping based C on inherited clustering done during analysis C Other values are treated as zero C Note that this functionality is currently incompatible with elemental matrices C (ICNTL(5) = 1) and with forward elimination during factorization (ICNTL(32) = 1). C C ICNTL(38) not used in this version C C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 40 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 arry 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. 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 Note that it does not include null pivots C that might have been C further detected on the root (ICNTL(16).NE.0). 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 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=========================== 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:40) = 0 INFOG(1:40) = 0 ICNTL(1:40) = 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 CNTL(6) = -1.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 IF (NSLAVES .GT. 4) THEN ICNTL(14) = 30 ELSE ICNTL(14) = 20 END IF C Minimum size of the null space ICNTL(15) = 0 C Do not look for rank/null space basis ICNTL(16) = 0 C Max size of null space ICNTL(17) = 0 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 --------- Non documented ICNTL options C Old or new symbolic factorization ICNTL(39) = 1 ICNTL(40) = 0 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 C KEEP(11) = 2147483646 KEEP(11) = huge(KEEP(11)) KEEP(24) = 18 KEEP(68) = 0 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 500 KEEP(58) = 250 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 KEEP(17) = 0 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 !write(6,*) ' TEMPORARY new splitting active, K79=', KEEP(79) 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(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 #if ! defined(NO_XXNBPR) KEEP(121)=-999999 #endif KEEP(122)=150 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)=50 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 DKEEP(10) = 1000.0D0 ! > 0 : GAP IF(NSLAVES.LE.8)THEN KEEP(238)=12 ELSE KEEP(238)=7 ENDIF KEEP(234)= 1 KEEP(235)=-1 DKEEP(3)=-5.0D0 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) = 0 KEEP(266) = 0 KEEP(267) = 0 KEEP(350) = 1 KEEP(351) = 0 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 KEEP(468) = 3 KEEP(469) = 1 KEEP(470) = 1 KEEP(471) = -1 KEEP(480) = 0 KEEP(479) = 1 KEEP(478) = 0 KEEP(474) = 0 KEEP(481) = 0 KEEP(482) = 0 KEEP(472) = 1 KEEP(473) = 0 KEEP(475) = 0 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 50 KEEP(484) = 50 KEEP(485) = 1 ! (1 promote factors) 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(489) = 0 KEEP(490) = 128 KEEP(491) = 1000 KEEP(492) = 1 KEEP(82) = 30 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 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%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 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.1.2/src/sfac_par_m.F0000664000175000017500000007723313164366263015742 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS,ND,FILS,STEP, & FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, NTOTPV, NMAXNPIV, PTRIST, PTRAST, & PIMASTER, PAMASTER, PTRARW, PTRAIW, & ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, & LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, NSTEPS, 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_LR 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 IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER N,NTOTPV,MAXFRT,LIW, LPTRAR, NMAXNPIV, & NSTEPS, INFO(40) 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(40) 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)), NBPROCFILS(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 MAXFRW, NPVW, NOFFW, NELVAW, COMP, & JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' DOUBLE PRECISION OPASSW, OPELIW ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL PTRIST(1:KEEP(28))=0 PTLUST(1:KEEP(28))=0 PTRAST(1:KEEP(28))=0_8 PTRFAC(1:KEEP(28))=-99999_8 PIMASTER(1:KEEP(28))=-99999_8 PAMASTER(1:KEEP(28))=-99999_8 MP = ICNTL(2) LP = ICNTL(1) MAXFRW = 0 NPVW = 0 NOFFW = 0 NELVAW = 0 COMP = 0 OPASSW = DZERO OPELIW = DZERO IWPOSCB = LIW 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, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 NBPROCFILS(1:KEEP(28)) = 0 #if ! defined(NO_XXNBPR) KEEP(121)=0 #endif IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL SMUMPS_ROOT_ALLOC_STATIC( & root, KEEP(38), N, IW, LIW, & A, LA, & FILS, MYID_NODES, 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 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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 (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)),SLAVEF) 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, NOFFW, NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ELSE CALL SMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, NOFFW, NPVW, & 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,NBPROCFILS,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 ( 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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,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, & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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,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, & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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 ( INFO(1) .LT. 0 ) GOTO 640 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTLUST(STEP(INODE))+XXNBPR) ) IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN #else IF ((NBPROCFILS(STEP(INODE)).GT.0).OR.(SON_LEVEL2)) THEN #endif 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, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NBPROCFILS, 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, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF 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, NOFFW, NPVW, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & ) ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL SMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFW, NPVW, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & ) 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,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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,NBPROCFILS, 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 (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) 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),OPELIW,NELVAW,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, & LRLUS,IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, NBPROCFILS, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, OPASSW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) 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)),SLAVEF).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)),SLAVEF)) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, 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,SLAVEF, & 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) .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)))), & SLAVEF) 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( 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, & OPELIW ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & SLAVEF) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NPVW = NPVW + INFO(2) ELSE NPVW = NPVW + 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(70) = KEEP8(70) + ITMP8 KEEP8(71) = KEEP8(71) + 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 CALL MUMPS_SET_IERROR(LRHS_CNTR_MASTER_ROOT,INFO(2)) 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)) NPVW = NPVW + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & NFRONT8*NFRONT8 ) THEN POSFAC = POSFAC - NFRONT8*NFRONT8 LRLUS = LRLUS + NFRONT8*NFRONT8 LRLU = LRLUS + NFRONT8*NFRONT8 KEEP8(70) = KEEP8(70) + NFRONT8*NFRONT8 KEEP8(71) = KEEP8(71) + NFRONT8*NFRONT8 CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-NFRONT8*NFRONT8,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))),SLAVEF) & ) THEN MAXFRW = max ( MAXFRW, root%TOT_ROOT_SIZE) END IF END IF MAXFRT = MAXFRW NTOTPV = NPVW INFO(12) = NOFFW RINFO(2) = real(OPASSW) RINFO(3) = real(OPELIW) INFO(13) = NELVAW INFO(14) = COMP 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.1.2/src/smumps_ooc_buffer.F0000664000175000017500000004246013164366263017357 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC_BUF_PANEL' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC_BUF_PANEL' 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) & WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC_BUF_PANEL' 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.1.2/src/zana_lr.F0000664000175000017500000003527613164366266015302 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1)) 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)) 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 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) :: LRGROUPS(N), VLIST(NV), TRACE(N) 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 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, INTENT(INOUT) :: LRGROUPS(N) INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1)) NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO PARTPTR(1)=1 CNT = 0 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 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 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 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 INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP)) ALLOCATE(PERM(NSEP)) ALLOCATE(IPERM(NSEP)) ALLOCATE(SIZES(NPARTS)) ALLOCATE(PARTPTR(NPARTS+1)) 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)) 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 END MODULE ZMUMPS_ANA_LR MUMPS_5.1.2/src/tools_common.F0000664000175000017500000006405513164366241016352 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_TYPENODE(PROCINFO_INODE, SLAVEF) IMPLICIT NONE INTEGER SLAVEF INTEGER PROCINFO_INODE, TPN IF (PROCINFO_INODE <= SLAVEF ) THEN MUMPS_TYPENODE = 1 ELSE TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 IF ( TPN .LT. 1 ) TPN = 1 IF (TPN.EQ.4.OR.TPN.EQ.5.OR.TPN.EQ.6) TPN = 2 MUMPS_TYPENODE = TPN END IF RETURN END FUNCTION MUMPS_TYPENODE INTEGER FUNCTION MUMPS_PROCNODE(PROCINFO_INODE, SLAVEF) IMPLICIT NONE INTEGER SLAVEF INTEGER PROCINFO_INODE IF (SLAVEF == 1) THEN MUMPS_PROCNODE = 0 ELSE MUMPS_PROCNODE=mod(2*SLAVEF+PROCINFO_INODE-1,SLAVEF) END IF RETURN END FUNCTION MUMPS_PROCNODE INTEGER FUNCTION MUMPS_TYPESPLIT (PROCINFO_INODE, SLAVEF) IMPLICIT NONE INTEGER, intent(in) :: SLAVEF INTEGER PROCINFO_INODE, TPN IF (PROCINFO_INODE <= SLAVEF ) THEN MUMPS_TYPESPLIT = 1 ELSE TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 IF ( TPN .LT. 1 ) TPN = 1 MUMPS_TYPESPLIT = TPN ENDIF RETURN END FUNCTION MUMPS_TYPESPLIT LOGICAL FUNCTION MUMPS_ROOTSSARBR( PROCINFO_INODE, SLAVEF ) IMPLICIT NONE INTEGER SLAVEF INTEGER TPN, PROCINFO_INODE TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 MUMPS_ROOTSSARBR = ( TPN .eq. 0 ) RETURN END FUNCTION MUMPS_ROOTSSARBR LOGICAL FUNCTION MUMPS_INSSARBR( PROCINFO_INODE, SLAVEF ) IMPLICIT NONE INTEGER SLAVEF INTEGER TPN, PROCINFO_INODE TPN = (PROCINFO_INODE-1+SLAVEF+SLAVEF)/SLAVEF - 1 MUMPS_INSSARBR = ( TPN .eq. -1 ) RETURN END FUNCTION MUMPS_INSSARBR LOGICAL FUNCTION MUMPS_IN_OR_ROOT_SSARBR & ( PROCINFO_INODE, SLAVEF ) IMPLICIT NONE INTEGER SLAVEF INTEGER TPN, PROCINFO_INODE TPN = (PROCINFO_INODE-1+SLAVEF+SLAVEF)/SLAVEF - 1 MUMPS_IN_OR_ROOT_SSARBR = & ( TPN .eq. -1 .OR. TPN .eq. 0 ) RETURN END FUNCTION MUMPS_IN_OR_ROOT_SSARBR 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(N, LEAF, & MYID_NODES, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) IMPLICIT NONE INTEGER N, LEAF, MYID_NODES, & SLAVEF, 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)),SLAVEF) & .EQ.MYID_NODES) THEN IPOOL(LEAF) = INODE LEAF = LEAF + 1 ENDIF ENDDO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST SUBROUTINE MUMPS_INIT_NROOT_DIST(N, NBROOT, & NROOT_LOC, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, & PROCNODE_STEPS) 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 MUMPS_PROCNODE 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)), & SLAVEF).EQ.MYID_NODES) THEN NROOT_LOC = NROOT_LOC + 1 END IF ENDDO RETURN END SUBROUTINE MUMPS_INIT_NROOT_DIST 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_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 IF(ICNTL6.EQ.0 .AND. ICNTL8.EQ.0) RETURN IF ( (KEEP54.NE.0).AND. (KEEP50.NE.1) & .AND. (KEEP12 .GT. 0) ) KEEP12= KEEP12+5 RETURN END SUBROUTINE MUMPS_GET_PERLU 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 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(40) 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 CMUMPS_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 &CMUMPS_REORDER_TREE' 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 #if ! defined(NO_XXNBPR) SUBROUTINE CHECK_EQUAL(NBPR, IWNBPR) IMPLICIT NONE INTEGER, intent(in) :: NBPR, IWNBPR IF (NBPR .NE. IWNBPR) THEN WRITE(*,*) " NBPROCFILS(...), IW(..+XXNBPR_ = ", NBPR, IWNBPR #if ! defined(IBC_TEST) CALL MUMPS_ABORT() #endif ENDIF RETURN END SUBROUTINE CHECK_EQUAL #endif 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_COPY_INT_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_COPY_INT_32TO64 SUBROUTINE MUMPS_COPY_INT_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_COPY_INT_32TO64_64C SUBROUTINE MUMPS_COPY_INT_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_COPY_INT_64TO32 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 MUMPS_5.1.2/src/sfac_front_aux.F0000664000175000017500000020316413164366263016643 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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,IOLDPS,POSELT,UU,SEUIL,KEEP, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER KEEP(500) 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 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 NOFFW,NPIV,IPIV,IPIV_SHIFT 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 !$ INTEGER :: JJMAX !$ REAL :: RRMAX, VALABS !$ INTEGER :: NOMP, CHUNK, K360 !$ K360 = KEEP(360) !$ NOMP = OMP_GET_MAX_THREADS() NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) 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)).GT.max(UU*MAXFROMN,SEUIL, & tiny(MAXFROMN))) 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 IF (KEEP(351).EQ.1) THEN !$ IF (NOMP.GT.1 .AND. J3.GE.K360) THEN !$ JMAX = 1 !$ RMAX = RZERO !$ CHUNK = max(K360/2,J3/NOMP) !$OMP PARALLEL PRIVATE(JJ,VALABS,JJMAX,RRMAX) !$OMP& FIRSTPRIVATE(J1,NFRONT8,J3) !$ RRMAX = RZERO !$OMP DO schedule(static, CHUNK) !$ DO J = 1, J3 !$ JJ = J1 + int(J-1,8)*NFRONT8 !$ VALABS = abs(A(JJ)) !$ IF (VALABS.GT.RRMAX) THEN !$ RRMAX = VALABS !$ JJMAX = J !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (RRMAX.GT.0.0) THEN !$OMP CRITICAL !$ IF (RRMAX.GT.RMAX) THEN !$ RMAX = RRMAX !$ JMAX = JJMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE JMAX = SMUMPS_IXAMAX(J3,A(J1),NFRONT) !$ ENDIF ELSE JMAX = SMUMPS_IXAMAX(J3,A(J1),NFRONT) ENDIF 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) 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) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(J1) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) IF (J3.GE.K360) DO J=1,J3 J1 = J1_ini + int(J-1,8) * NFRONT8 RMAX = max(abs(A(J1)),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)).GT.max(UU*RMAX,SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE.max(UU*RMAX,SEUIL,tiny(RMAX))) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DKEEP(6), & KEEP(259) ) ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 KEEP(260)=-KEEP(260) 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 KEEP(260)=-KEEP(260) 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 (KEEP(201).EQ.1) 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) !$ 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 NEL,IROW,NEL2,JCOL, NCB INTEGER NPIVP1 REAL, PARAMETER :: ONE = 1.0E0 !$ LOGICAL:: OMP_FLAG !$ INTEGER:: NOMP, K360, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ K360 = KEEP(360) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NEL2 = NASS - NPIVP1 NCB = NFRONT - NASS - KEEP(253) IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) !$ OMP_FLAG = .FALSE. !$ CHUNK = NEL !$ 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) !$ ENDIF !$ ELSE !$ OMP_FLAG = .TRUE. !$ CHUNK = max(K360/2,NEL/NOMP) !$ 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) 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_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM & ) IMPLICIT NONE INTEGER(8) :: LA,POSELT REAL A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL CALL_UTRSM INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1,NEL11 REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) CALL strsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_UTRSM) THEN UPOS = POSELT + int(NASS,8) CALL strsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) CALL sgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE SMUMPS_FAC_P SUBROUTINE SMUMPS_FAC_P_PANEL(A,LAFAC,NFRONT, & NPIV,NASS, IW, LIWFAC, & MonBloc, TYPEFile, MYID, KEEP8, & STRAT, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten) USE SMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NPIV, NASS INTEGER(8) :: LAFAC INTEGER LIWFAC, TYPEFile, MYID, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten, STRAT REAL A(LAFAC) INTEGER IW(LIWFAC) INTEGER(8) KEEP8(150) TYPE(IO_BLOCK) :: MonBloc INTEGER(8) :: LPOS2,LPOS1,LPOS INTEGER NEL1,NEL11 REAL ALPHA, ONE LOGICAL LAST_CALL PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = 1_8 + int(NASS,8) * int(NFRONT,8) CALL strsm('L','L','N','N',NPIV,NEL1,ONE,A(1),NFRONT, & A(LPOS2),NFRONT) LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) LPOS = LPOS2 + int(NPIV,8) LPOS1 = int(1 + NPIV,8) CALL sgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE SMUMPS_FAC_P_PANEL 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, & CALL_UTRSM, CALL_GEMM, WITH_COMM_THREAD ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD INTEGER(8) :: NFRONT8 INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER NELIM, LKJIW, NEL1, NEL11 REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) 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 IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + & int(IEND_BLOCK,8) POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*NFRONT8 + int(IBEG_BLOCK - 1,8) CALL strsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) IF (CALL_UTRSM) THEN CALL strsm('R','U','N','U',NEL1,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),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 ENDIF RETURN END SUBROUTINE SMUMPS_FAC_SQ SUBROUTINE SMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB) 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) 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, LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG) USE SMUMPS_OOC IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW, & 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) TYPE(IO_BLOCK), intent(inout) :: MonBloc INTEGER :: NPIV, NEL1, STRAT, TYPEFile, IFLAG_OOC, & 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 (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_BOTH_LU MonBloc%LastPiv= NPIV CALL SMUMPS_FAC_P_PANEL(A(POSELT), LAFAC, NFRONT, & NPIV, NASS, IW(IOLDPS), LIWFAC, & MonBloc, TYPEFile, MYID, KEEP8, & STRAT, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC ELSE CALL SMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM & ) ENDIF 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,IOLDPS,POSELT,UU,SEUIL, & KEEP, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv & ) IF (INOPV.NE.1) THEN CALL SMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL) 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,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, & 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 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 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 REAL PIVNUL REAL FIXA, CSEUIL INTEGER NPIV,IPIV INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF INTEGER SMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0E0/ !$ INTEGER :: J4,JJMAX,NOMP,CHUNK,K361 !$ REAL :: RRMAX,VALABS INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U !$ NOMP = OMP_GET_MAX_THREADS() !$ K361 = KEEP(361) 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 IF (KEEP(201).EQ.1) 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 IF(abs(A(APOS)).LT.SEUIL) THEN IF (real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF KEEP(98) = KEEP(98)+1 ELSE IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1) 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.GT.0.AND.UU.GT.RZERO) GO TO 340 IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 340 CONTINUE 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 IF (KEEP(351).EQ.1) THEN !$ IF (NOMP.GT.1 .AND. J.GE.K361) THEN !$ JMAX = 1 !$ RMAX = RZERO !$ CHUNK = max(K361/2,J/NOMP) !$OMP PARALLEL PRIVATE(J3,VALABS,JJMAX,RRMAX) !$OMP& FIRSTPRIVATE(J1,J) !$ RRMAX = RZERO !$OMP DO schedule(static, CHUNK) !$ DO J4 = 1, J !$ J3 = J1 + int(J4-1,8) !$ VALABS = abs(A(J3)) !$ IF(VALABS.GT.RRMAX) THEN !$ RRMAX = VALABS !$ JJMAX = J4 !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (RRMAX.GT.0.0) THEN !$OMP CRITICAL !$ IF (RRMAX.GT.RMAX) THEN !$ RMAX = RRMAX !$ JMAX = JJMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE JMAX = SMUMPS_IXAMAX(J,A(J1),1) !$ ENDIF ELSE JMAX = SMUMPS_IXAMAX(J,A(J1),1) ENDIF 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),8) ELSE J2 = APOS +int(- NPIV + NASS - 1 - KEEP(253),8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1) THEN !$ CHUNK = max(K361/2,int(J2-J1)/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 ENDIF 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF ( RMAX .LE. PIVNUL ) THEN 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(LAST_ROW-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LAST_ROW-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO KEEP(109) = KEEP(109)+1 ISW = IOLDPS+HF+ & IW(IOLDPS+1+XSIZE)+IPIV-NPIVP1 PIVNUL_LIST(KEEP(109)) = IW(ISW) 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 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 IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DKEEP(6), & KEEP(259)) ENDIF 385 CONTINUE IF (IPIV.EQ.NPIVP1) GO TO 400 KEEP(260)=-KEEP(260) 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 KEEP(260)=-KEEP(260) 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 (KEEP(201).EQ.1) 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, & NNEG, & 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,INODE,IFLAG,INOPV, & IOLDPS, NNEG INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv 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 include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM REAL RMAX,AMAX,TMAX REAL MAXPIV REAL PIVNUL REAL FIXA, CSEUIL REAL PIVOT,DETPIV INCLUDE 'mumps_headers.h' 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) LOGICAL OMP_FLAG INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEG = NNEG+1 ENDIF KEEP(98) = KEEP(98)+1 ELSE IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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) NNEG = NNEG+1 IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) 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) NNEG = NNEG+1 IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. 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 + 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 IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSEIF (PIVOT_OPTION.EQ.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT: PIVOT_OPTION=', & PIVOT_OPTION ENDIF J1_ini = J1 IF ( (LIM - KEEP(253) - IEND_BLOCK).GE.300 ) THEN OMP_FLAG = .TRUE. ELSE OMP_FLAG = .FALSE. ENDIF !$OMP PARALLEL DO PRIVATE(J1) REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - KEEP(253) - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN KEEP(109) = KEEP(109)+1 PIVNUL_LIST(KEEP(109)) = -1 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,NFRONT - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN IF (PIVOT .LT. ZERO) NNEG = NNEG+1 IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) 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,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSEIF (PIVOT_OPTION.EQ.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT: PIVOT_OPTION=', & PIVOT_OPTION 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 (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 OMP_FLAG = (LIM-JMAX-KEEP(253). GE. 300) !$OMP PARALLEL DO IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX - KEEP(253) 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_FLAG = (LIM-JMAX-KEEP(253). GE. 300) !$OMP PARALLEL DO PRIVATE(JJ) REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX-KEEP(253) 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 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 IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(103) = KEEP(103)+1 IF(DETPIV .LT. RZERO) THEN NNEG = NNEG+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEG = NNEG+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 CALL SMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDA, NFRONT, 1, KEEP(219), KEEP(50), & KEEP(IXSZ), -9999) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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, & KEEP253, PIVOT_OPTION, IEND_BLR & ) 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) :: PIVOT_OPTION, IEND_BLR INTEGER(8) :: POSELT REAL, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, INTENT(in) :: KEEP253 REAL VALPIV REAL :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2, NEL, LIM 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 REAL SWOP,DETPIV,MULT1,MULT2 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 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 MAXFROMM = 0.0E00 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 IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSE LIM = IEND_BLR ENDIF NCB1 = LIM - IEND_BLOCK 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 - KEEP253 > 300) DO I=NEL2+1, NEL2 + NCB1 - KEEP253 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 - KEEP253 + 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 ELSE IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSE LIM = IEND_BLR ENDIF 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(LIM-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL scopy(LIM-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 DO J2 = IEND_BLOCK+1,LIM 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 JJ = JJ + NFRONT8 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_FAC_MQ_LDLT SUBROUTINE SMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,LAST_VAR,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & PIVOT_OPTION, CALL_TRSM) 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, intent(in) :: LAST_VAR INTEGER :: KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: PIVOT_OPTION LOGICAL, intent(in) :: CALL_TRSM INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1, I, II INTEGER(8) :: LPOS,UPOS,APOS INTEGER IROW INTEGER Block INTEGER BLSIZE, ELSIZE REAL ONE, ALPHA, VALPIV INCLUDE 'mumps_headers.h' PARAMETER (ONE=1.0E0, ALPHA=-1.0E0) LDA8 = int(LDA,8) ELSIZE = IEND_BLOCK - IBEG_BLOCK +1 NEL1 = LAST_VAR - IEND_BLOCK NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (PIVOT_OPTION.LE.1.AND.CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) CALL strsm('L', 'U', 'T', 'U', ELSIZE, NEL1, ONE, & A(APOS), LDA, A(LPOS), LDA) !$OMP PARALLEL PRIVATE(VALPIV,I,II) DO I = 1, ELSIZE VALPIV = ONE/A(POSELT+(LDA8+1_8)*int(IBEG_BLOCK+I-2,8)) !$OMP DO DO II = 1,NEL1 A(UPOS+int(I-1,8)*LDA8 + int(II-1,8)) = & A(LPOS+int(I-1,8) + int(II-1,8)*LDA8) A(LPOS+int(I-1,8) + int(II-1,8)*LDA8) = & A(LPOS+int(I-1,8) + int(II-1,8)*LDA8)*VALPIV ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ENDIF IF ( LAST_VAR - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_VAR - IEND_BLOCK END IF IF ( NASS - IEND_BLOCK .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = IEND_BLOCK+1, LAST_VAR, BLSIZE Block = min( BLSIZE, NASS - 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_VAR, BLSIZE Block = min( BLSIZE, LAST_VAR - 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_VAR - IROW + 1, NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF LPOS = POSELT + int(LAST_VAR,8)*LDA8 + int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_VAR,8)*LDA8 + int(IEND_BLOCK,8) IF (PIVOT_OPTION.EQ.3) THEN CALL sgemm('N', 'N', NEL1, NFRONT-LAST_VAR, NPIV_BLOCK, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) ELSEIF (PIVOT_OPTION.EQ.2.AND.(NASS.GT. LAST_VAR)) THEN CALL sgemm('N', 'N', NEL1, NASS-LAST_VAR, NPIV_BLOCK, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_SQ_LDLT SUBROUTINE SMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, NASS, & LDA, NFRONT, LEVEL, K219, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, NASS, LEVEL, K219, K50, XSIZE REAL A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: LASTROW2SWAP, 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 IF (LEVEL .EQ. 1) THEN LASTROW2SWAP = NFRONT ELSE LASTROW2SWAP = NASS ENDIF CALL sswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF (K219.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2) 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_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) 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 INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, I, J, IROWEND INTEGER I2, I2END, Block2 REAL ONE, ALPHA, BETA, ZERO REAL :: MULT1, MULT2, A11, DETPIV, A22, A12 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(57) ) THEN BLSIZE = KEEP(58) 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 CALL strsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NPIV, ONE, & A( POSELT ), LDA, & A( POSELT + LDA8 * int(NPIV,8) ), LDA ) 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 DPOS = POSELT I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN A11 = ONE/A(DPOS) CALL scopy(Block, A(LPOS+int(I-1,8)), LDA, & A(UPOS+int(I-1,8)*LDA8), 1) CALL sscal(Block, A11, A(LPOS+int(I-1,8)), LDA) DPOS = DPOS + int(LDA+1,8) I = I+1 ELSE CALL scopy(Block, A(LPOS+int(I-1,8)), LDA, & A(UPOS+int(I-1,8)*LDA8), 1) CALL scopy(Block, A(LPOS+int(I,8)), LDA, & A(UPOS+int(I,8)*LDA8), 1) 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,Block 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 DPOS = POSPV2 + int(LDA+1,8) I = I+2 ENDIF ENDDO 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 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 END MODULE SMUMPS_FAC_FRONT_AUX_M MUMPS_5.1.2/src/cini_driver.F0000664000175000017500000001747513164366266016152 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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" 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 C Reception buffer initialized to zero NULLIFY(id%BUFR) C id%MAXIS1 = 0 C C id%INST_Number = -1 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) id%LSOL_loc=0 NULLIFY(id%SOL_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%IS1) NULLIFY(id%STEP) 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%PROCNODE) 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) 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_BEFORE_L0_OMP) NULLIFY(id%IPOOL_AFTER_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) 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.1.2/src/dfac_mem_compress_cb.F0000664000175000017500000002774213164366263017762 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INCLUDE 'mumps_headers.h' 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 SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE DMUMPS_SIZEFREEINREC 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) IMPLICIT NONE INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER N,LIW,KEEP28, & IWPOS,IWPOSCB,KEEP216,XSIZE INTEGER(8) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER IW(LIW),PTRIST(KEEP28), & STEP(N), PIMASTER(KEEP28) DOUBLE PRECISION 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 INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE INTEGER IXXP 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 IF ( STATE_NEXT .NE. S_FREE .AND. & (KEEP216.EQ.3.OR. & (STATE_NEXT .NE. S_NOLCBNOCONTIG .AND. & STATE_NEXT .NE. S_NOLCBCONTIG .AND. & STATE_NEXT .NE. S_NOLCBNOCONTIG38 .AND. & STATE_NEXT .NE. S_NOLCBCONTIG38))) THEN CALL DMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) 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 (RSIZE2SHIFT .NE. 0_8) THEN IF (PTRAST(STEP(INODE)).EQ.RCURRENT) & PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT IF (PAMASTER(STEP(INODE)).EQ.RCURRENT) & PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT 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 IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN IF ( KEEP216.eq.3) THEN WRITE(*,*) "Internal error 2 in DMUMPS_COMPRE_NEW" ENDIF 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) 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) 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) ELSE 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 INODE=IW(ICURRENT+XXN) IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) IF (STATE_NEXT.EQ.S_NOLCBCONTIG.OR. & STATE_NEXT.EQ.S_NOLCBNOCONTIG) THEN IW(ICURRENT+XXS)=S_NOLCLEANED ELSE IW(ICURRENT+XXS)=S_NOLCLEANED38 ENDIF 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 MUMPS_5.1.2/src/csol_driver.F0000664000175000017500000065541413164366266016171 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_SOLVE_DRIVER(id) USE CMUMPS_STRUC_DEF USE MUMPS_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 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,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK 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 MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL 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(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSCOMP INTEGER :: PERM_PIV_LIST(max(id%KEEP(112),1)) INTEGER :: MAP_PIVNUL_LIST(max(id%KEEP(112),1)) 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_PIV_LIST permuted array of pivots C MAP_PIVNUL_LIST: mapping of permuted list 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(:) 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_IN_RHSCOMP_F, & NB_FS_IN_RHSCOMP_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV 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.0 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 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 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_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 WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE 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) IS_INIT_OOC_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)) 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. 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_IN_RHSCOMP_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_IN_RHSCOMP_F = NB_FS_IN_RHSCOMP_TOT 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 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 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 in fact effectively C -- 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 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 WRITE(6,*) " WARNING !!! A-1 OFF and KEEP(242)= ", & KEEP(242), " is reset to zero (OFF)" C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder ELSE KEEP(242) = 0 ! no permutation ENDIF 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 id%KEEP(243)=0 id%KEEP(495)=0 IF (id%KEEP(235) .EQ. 1) THEN IF (id%KEEP(497).EQ.-1) 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 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(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 ISOL_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) WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' 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) WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' 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) WRITE(MPG,'(A)') & ' ERROR: id%NRHS not allowed to change when ICNTL(32)=1' 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) WRITE(MPG,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' 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) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE INFO(2) = 20 ! ICNTL(20) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: sparse RHS incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS 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 ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 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),MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 IF (KEEP(111).eq.-1.AND.id%NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=id%NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. id%NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=id%NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN C Ignore sparse RHS in case we compute C vectors of the null space (KEEP(111)).NE.0.) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! icntl(30) IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ELSE IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' INFO(2) = 20 ! inclt(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 END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21==1) THEN IF ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) 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 (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, LSCAL ) 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((J-1)*id%LRHS + I) =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 ) & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30) 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 MUMPS_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 #if defined(RHSCOMP_BYROWS) C In case of row storage with reduced right hand side, we C do not take into account empty columns during forward. C Therefore NRHS_NONEMPTY will simply be set to id%NRHS & .AND. KEEP(221) .NE. 1 #endif & ) 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))), & id%NSLAVES ) 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))), & id%NSLAVES ) 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 C Avoid to have overflows in NFRONT * NBRHS C 32-bit integer compuitations. C Should be hopefully large-enough for a while. IF(huge(NBRHS)/id%KEEP(133).LT.NBRHS) THEN IF (PROKG) WRITE(MPG,'(A,I6,A)')'Warning: NBRHS = ',NBRHS, & ' might be too large.' NBRHS = huge(NBRHS)/id%KEEP(133)-1 ! -1 to avoid rounding pbs IF (PROKG) WRITE(MPG,'(A,I6)')'NBRHS reset to ',NBRHS END IF 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 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 (id%MYID.EQ.MASTER) THEN IF ( PROKG ) THEN WRITE( MPG, 150 ) & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30) 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).OR.(KEEP(237).NE.0).OR. & (KEEP(252).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)') & ' WARNING: Incompatible features: null space basis ', & ' 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)') & ' 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)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' 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) & WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' INFO(1) = -13 INFO(2) = id%N*NBRHS GOTO 111 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 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(111),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_SOLVE = ( 4 + KEEP(133) ) * KEEP(34) + & KEEP(133) * NBRHS * KEEP(35) & + 16 * KEEP(34) ! for request id, pointer to next + safety C -------------------------------------- C Compute an upperbound of message size C for CMUMPS_GATHER_SOLUTION C -------------------------------------- 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) 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 MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for CMUMPS_GATHER_SOLUTION id%LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) id%LBUFR_BYTES = max(id%LBUFR_BYTES,TSIZE) id%LBUFR = ( id%LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) IF ( associated (id%BUFR) ) THEN NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) ENDIF ALLOCATE (id%BUFR(id%LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) & WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' INFO(1) = -13 INFO(2) = id%LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(id%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) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C CALL MPI_BCAST(KEEP(497),1,MPI_INTEGER,MASTER, & id%COMM,IERR) 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) & WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on a slave' 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 = 3 * KEEP(28) + 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) 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 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 IF ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) 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 solution C ------------------------------------- IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN C In case of scaling we will need to scale C back the RHS. 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 40 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data%SCALING=>id%ROWSCA ENDIF IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%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 40 ENDIF NB_BYTES = NB_BYTES + int(id%KEEP(89),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF 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, LSCAL ) 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 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 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 CALL MUMPS_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 MUMPS_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 C Phase 1 : CMUMPS_PERMUTE_RHS_NS C local permutations to minimize sequential disk access C with chunck of size KEEP(84)/NSLAVES C Phase 2 : CMUMPS_SOL_APPLY_PARPERM C parallel redistribution to exploit // disk access feature IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C Phase 1 to be called on each proc 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) THEN IF ( KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ELSE 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 MUMPS_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(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 / NS ENDIF ! End 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 defined(RHSCOMP_BYROWS) C In case RHSCOMP is stored by rows, we need to ensure C that the blocks during forward and backward are the C same. For that, a simple and safe solution consists in C avoiding skipping empty columns during the forward step. IF (KEEP(221).NE.1) THEN #endif 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((PERM_RHS(JBEG_RHS) -1)*LD_RHS+I) & = 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((JBEG_RHS -1)*LD_RHS + I) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN C Reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR #if defined(RHSCOMP_BYROWS) ENDIF C In that case we will have NB_RHSSKIPPED=0 C and we have JBEG_RHS = JEND_RHS+1 IF (KEEP(221).EQ.1) THEN IF ( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) THEN DO J=JBEG_RHS, JBEG_RHS + NBRHS_EFF -1 DO I=1, id%SIZE_SCHUR id%REDRHS((J-1)*LD_REDRHS + I) = ZERO ENDDO ENDDO ENDIF ENDIF #endif 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 #if defined(RHSCOMP_BYROWS) C In case of forward-only, we do not skip empty RHS. C This would cause problems during the backward phase: since C each block of RHSCOMP has a row-major storage and inside C each block, data is congiguous, blocks must be the same C during forward and during backward. Hence NB_RHSSKIPPED C will be 0. C & .OR. KEEP(221) .EQ. 1 #endif & ) 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 defined(RHSCOMP_BYROWS) IF (NZ_THIS_BLOCK .eq. 0) THEN C Skip block, C set REDRHS, RHSCOMP will be set later IF (KEEP(221).EQ.1) THEN DO J=JBEG_RHS, JBEG_RHS+ NBRHS_EFF -1 DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDDO ELSE WRITE(*,*) "Internal error 15 is sol_driver" CALL MUMPS_ABORT() ENDIF ENDIF #else IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF #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).NE.0) ) 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 ========================================================== 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).EQ.0 .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 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_IN_RHSCOMP_TOT ) NB_FS_IN_RHSCOMP_F = NB_FS_IN_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_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT, & UNS_PERM_INV, size(UNS_PERM_INV) ! size 1 if not used & ) ENDIF ENDIF ! BUILD_POSINRHSCOMP=.TRUE. 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 #if defined(RHSCOMP_BYROWS) C Stored by rows but only inside each C block. We keep IBEG_RHSCOMP unchanged C for locality since both SCATTER_RHS and C GATHER_SOLUTION will be done block-by-block? IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 #else IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 #endif 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 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 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 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 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(PERM_RHS(I)) * & 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(PERM_RHS(I))+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+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 IF(id%MYID.EQ.MASTER) 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_IN_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 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, * - to build Ej and store it in RHSCOMP K=1 ! Column index in RHSCOMP id%RHSCOMP(1:NBRHS_EFF*LD_RHSCOMP) = 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_IN_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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP((IPOSRHSCOMP-1)*NBRHS_EFF+K) = & RHS_SPARSE_COPY(IPOS) #else id%RHSCOMP((K-1)*LD_RHSCOMP+IPOSRHSCOMP) = & RHS_SPARSE_COPY(IPOS) #endif 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 #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error 17 is sol driver" CALL MUMPS_ABORT() #else DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, LD_RHSCOMP id%RHSCOMP((K-1)*LD_RHSCOMP + I) = ZERO ENDDO ENDDO #endif ENDIF #if defined(RHSCOMP_BYROWS) IF (I_AM_SLAVE) THEN DO I=1, NBENT_RHSCOMP DO K = 1, NBCOL_INBLOC C NBCOL_INBLOC is equal to NBRHS_EFF in this case id%RHSCOMP(IBEG_RHSCOMP+ & int(I-1,8)*int(NBRHS_EFF,8)+int(K-1,8))=ZERO ENDDO ENDDO ENDIF C Test below must be done also on non-working host !! IF (NZ_THIS_BLOCK .EQ. 0 .AND. KEEP(221).EQ.1) THEN C Skip the rest, go to next block. GOTO 1000 ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = IBEG_RHSCOMP + int(K-1,8) #else 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 #endif 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_IN_RHSCOMP_TOT IF ( (IPOSRHSCOMP.LE.NB_FS_IN_RHSCOMP_TOT) & .AND.(IPOSRHSCOMP.GT.0) ) THEN C ! I is fully summed var mapped on my proc #if defined(RHSCOMP_BYROWS) id%RHSCOMP(KDEC+(IPOSRHSCOMP-1)*NBRHS_EFF)= & id%RHSCOMP(KDEC+(IPOSRHSCOMP-1)*NBRHS_EFF) + & RHS_SPARSE_COPY(IZ) #else id%RHSCOMP(KDEC+IPOSRHSCOMP)= & id%RHSCOMP(KDEC+IPOSRHSCOMP) + & RHS_SPARSE_COPY(IZ) #endif 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 IF (INTERLEAVE_PAR .AND.(id%NSLAVES .GT. 1) ) THEN IRHS_SPARSE_COPY(II) = PERM_PIV_LIST(I) ELSE IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) ENDIF 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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP(1:NBRHS_EFF*LD_RHSCOMP)=ZERO #else 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 #endif 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 IF ((KEEP(235).NE.0) .AND. INTERLEAVE_PAR) THEN C When the PIVNUL_LIST has been permuted (in PERM_PIV_LIST) C then to exploit sparsity RHSCOMP need be initialized with c some care; taking into acount the processor localisation C of the indices of the null pivots. DO I=IBEG_GLOB_DEF,IEND_GLOB_DEF C Local processor is concerned by I-th column of C global right-hand side. IF (id%MYID_NODES .EQ. MAP_PIVNUL_LIST(I) ) THEN JJ= id%POSINRHSCOMP_ROW(PERM_PIV_LIST(I)) IF (JJ.GT.LD_RHSCOMP) THEN WRITE(6,*) ' Internal Error 10 JJ, LD_RHSCOMP=', & JJ, LD_RHSCOMP ENDIF IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN C unsymmetric : always set to fixation used during facto C because during factorization we aimed at preserving the C sign of the diagonal element, sign here may be different C from sign of corresponding diagonal element (not critical) #if defined(RHSCOMP_BYROWS) id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)* int(NBRHS_EFF,8)) = #else id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8)) = #endif & cmplx(abs(id%DKEEP(2)),kind=kind(id%RHSCOMP)) ELSE #if defined(RHSCOMP_BYROWS) id%RHSCOMP(IBEG_RHSCOMP + & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8) *int(NBRHS_EFF,8)) = ONE #else id%RHSCOMP(IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8)) = ONE #endif ENDIF ENDIF ENDIF ENDDO ELSE 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 #if defined(RHSCOMP_BYROWS) id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)*int(NBRHS_EFF,8) ) = #else id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8) ) = #endif & cmplx(id%DKEEP(2),kind=kind(id%RHSCOMP)) ELSE ! Symmetric: always set to one #if defined(RHSCOMP_BYROWS) id%RHSCOMP( IBEG_RHSCOMP+int(I-IBEG_GLOB_DEF,8) + & int(JJ-1,8)*int(NBRHS_EFF,8) )= #else id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8)+ & int(JJ-1,8) )= #endif & ONE ENDIF ENDIF ENDDO ENDIF ! exploit sparsity 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 IF(id%MYID.EQ.MASTER) THEN TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 ENDIF 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, & id%BUFR(1), id%LBUFR, id%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, & id%BUFR(1), id%LBUFR, id%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) C size 1 if not used & , UNS_PERM_INV, NB_FS_IN_RHSCOMP_F, NB_FS_IN_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 TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) 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 #if defined(RHSCOMP_BYROWS) LCWORK = NBRHS_EFF #else LCWORK = max(max(KEEP(247),KEEP(246)),1) #endif ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) 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 ) IF(id%MYID.EQ.MASTER) 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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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_IN_RHSCOMP_TOT & ) ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 ENDIF 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 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 COLSIZE = id%IRHS_PTR(PERM_RHS(J)+1) - & id%IRHS_PTR(PERM_RHS(J)) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 c IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PERM_RHS(J)), & id%IRHS_PTR(PERM_RHS(J)+1)-1 I = id%IRHS_SPARSE (IZ) DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN WRITE(6,*) " Internal Error 13 in solution ", & " driver, gather " CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ELSE ! Not (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 COLSIZE = id%IRHS_PTR(J+1) - id%IRHS_PTR(J) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 c IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(J), id%IRHS_PTR(J+1) - 1 I = id%IRHS_SPARSE (IZ) DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 IF (IRHS_SPARSE_COPY(IZ2).EQ.I) EXIT IF (IZ2.EQ.IRHS_PTR_COPY(JJ+1)-1) THEN WRITE(6,*) " Internal Error 14 in solution", & " driver, gather " CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR 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, 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 ) 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 ) 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 #if defined(RHSCOMP_BYROWS) 1000 CONTINUE #endif 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((PERM_RHS(JBEG_NEW) -1)*LD_RHS+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((JBEG_NEW -1)*LD_RHS + 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((PERM_RHS(JBEG_NEW) -1)*id%LSOL_LOC+I) & = 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((JBEG_NEW -1)*LD_REDRHS + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN #if defined(RHSCOMP_BYROWS) DO I=1,NBENT_RHSCOMP JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) id%RHSCOMP(JBEG_NEW + (I-1)*NBRHS_EFF) = ZERO JBEG_NEW = JBEG_NEW +1 ENDDO ENDDO #else JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSCOMP id%RHSCOMP((JBEG_NEW -1)*LD_RHSCOMP + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO #endif 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 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 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) IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Global statistics" WRITE( MPG, 434 ) id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) WRITE( MPG, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(116) ! non-zero if gather WRITE( MPG, 431 ) id%DKEEP(122) ! Distributed solution 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(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(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 (associated(id%BUFR)) THEN NB_BYTES = NB_BYTES - int(size(id%BUFR),8)*K34_8 DEALLOCATE(id%BUFR) NULLIFY(id%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%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%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 RHS (dist.sol)=',F15.6) 150 FORMAT(/' 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) 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_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_IN_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, id%BUFR(1), id%LBUFR, & id%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, C Case of special root node & 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), id%BUFR(1), id%LBUFR, id%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), id%BUFR(1), id%LBUFR, id%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.1.2/src/zlr_type.F0000664000175000017500000000422213164366266015507 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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,R INTEGER :: LRFORM,K,M,N,KSVD LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT,KEEP8,IS_FACTOR) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER(8) :: KEEP8(150) INTEGER :: MEM 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 KEEP8(70) = KEEP8(70) + int(MEM,8) IF (.NOT.IS_FACTOR) THEN KEEP8(71) = KEEP8(71) + int(MEM,8) ENDIF 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, NB_BLR, KEEP8, IS_FACTOR) INTEGER, INTENT(IN) :: NB_BLR TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) LOGICAL, INTENT(IN) :: IS_FACTOR INTEGER :: I IF (NB_BLR.GT.0) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=1, NB_BLR CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8, IS_FACTOR) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE ZMUMPS_LR_TYPE MUMPS_5.1.2/src/zfac_process_master2.F0000664000175000017500000001476713164366265017773 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, FRERE, & ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE ZMUMPS_LOAD 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 ), 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' 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, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, 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 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 IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & SLAVEF) .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(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, & SLAVEF, 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.1.2/src/zlr_stats.F0000664000175000017500000012434113164366266015671 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C MODULE ZMUMPS_LR_STATS USE ZMUMPS_LR_TYPE IMPLICIT NONE DOUBLE PRECISION :: ACC_MRY_CB_GAIN, & ACC_MRY_CB_FR, & FRONT_L11_BLR_SAVINGS, & FRONT_U11_BLR_SAVINGS, & FRONT_L21_BLR_SAVINGS, & FRONT_U12_BLR_SAVINGS, & ACC_FR_MRY, & GLOBAL_BLR_SAVINGS, & GLOBAL_MRY_LPRO_COMPR, & GLOBAL_MRY_LTOT_COMPR INTEGER :: CNT_NODES DOUBLE PRECISION :: FLOP_FR_UPDT, & FLOP_LR_UPDT, & FLOP_LR_UPDT_OUT, & FLOP_RMB, & FLOP_FR_TRSM, & FLOP_LR_TRSM, & FLOP_PANEL, & FLOP_TRSM, & FLOP_DEC_ACC, & FLOP_REC_ACC, & FLOP_DEMOTE, & FLOP_CB_DEMOTE, & FLOP_CB_PROMOTE, & LR_FLOP_GAIN DOUBLE PRECISION :: ACC_LR_FLOP_GAIN DOUBLE PRECISION :: ACC_FLOP_FR_FACTO, & ACC_FLOP_LR_FACTO, & ACC_FLOP_FR_TRSM, & ACC_FLOP_LR_TRSM, & ACC_FLOP_FR_UPDT, & ACC_FLOP_LR_UPDT, & ACC_FLOP_LR_UPDT_OUT, & ACC_FLOP_RMB, & ACC_FLOP_DEMOTE, & ACC_FLOP_CB_DEMOTE, & ACC_FLOP_CB_PROMOTE, & ACC_FLOP_TRSM, & ACC_FLOP_DEC_ACC, & ACC_FLOP_REC_ACC, & ACC_FLOP_PANEL, & ACC_FLOP_FRFRONTS, & ACC_FLOP_FR_SOLVE, & ACC_FLOP_LR_SOLVE DOUBLE PRECISION :: FACTOR_PROCESSED_FRACTION INTEGER(KIND=8) :: FACTOR_SIZE DOUBLE PRECISION :: TOTAL_FLOP DOUBLE PRECISION :: BLR_TIME_LRGROUPING DOUBLE PRECISION :: BLR_TIME_SEPGROUPING DOUBLE PRECISION :: BLR_TIME_GETHALO DOUBLE PRECISION :: BLR_TIME_KWAY DOUBLE PRECISION :: BLR_TIME_GNEW DOUBLE PRECISION :: ACC_UPDT_TIME DOUBLE PRECISION :: ACC_RMB_TIME DOUBLE PRECISION :: ACC_UPDT_TIME_OUT DOUBLE PRECISION :: ACC_PROMOTING_TIME DOUBLE PRECISION :: ACC_DEMOTING_TIME DOUBLE PRECISION :: ACC_CB_DEMOTING_TIME DOUBLE PRECISION :: ACC_LR_MODULE_TIME DOUBLE PRECISION :: ACC_TRSM_TIME DOUBLE PRECISION :: ACC_FRPANELS_TIME DOUBLE PRECISION :: ACC_FAC_I_TIME DOUBLE PRECISION :: ACC_FAC_MQ_TIME DOUBLE PRECISION :: ACC_FAC_SQ_TIME DOUBLE PRECISION :: ACC_FRFRONTS_TIME DOUBLE PRECISION :: AVG_ACC_FLOP_LR_FACTO DOUBLE PRECISION :: MIN_ACC_FLOP_LR_FACTO DOUBLE PRECISION :: MAX_ACC_FLOP_LR_FACTO 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 INTEGER, POINTER :: STEP_STATS(:) 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 UPDATE_ALL_TIMES(INODE, LOC_FACTO_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_FACTO_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_FRFRONTS_TIME, LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME ACC_UPDT_TIME = ACC_UPDT_TIME + LOC_FACTO_TIME ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + LOC_PROMOTING_TIME ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + LOC_DEMOTING_TIME ACC_CB_DEMOTING_TIME = ACC_CB_DEMOTING_TIME + & LOC_CB_DEMOTING_TIME ACC_FRPANELS_TIME = ACC_FRPANELS_TIME + LOC_FRPANELS_TIME ACC_FAC_I_TIME = ACC_FAC_I_TIME + LOC_FAC_I_TIME ACC_FAC_MQ_TIME = ACC_FAC_MQ_TIME + LOC_FAC_MQ_TIME ACC_FAC_SQ_TIME = ACC_FAC_SQ_TIME + LOC_FAC_SQ_TIME ACC_FRFRONTS_TIME = ACC_FRFRONTS_TIME + LOC_FRFRONTS_TIME ACC_TRSM_TIME = ACC_TRSM_TIME + LOC_TRSM_TIME ACC_LR_MODULE_TIME = ACC_LR_MODULE_TIME + LOC_LR_MODULE_TIME END SUBROUTINE UPDATE_ALL_TIMES SUBROUTINE UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_CB_DEMOTING_TIME ACC_CB_DEMOTING_TIME = ACC_CB_DEMOTING_TIME + & LOC_CB_DEMOTING_TIME END SUBROUTINE UPDATE_CB_DEMOTING_TIME SUBROUTINE UPDATE_UPDT_TIME(INODE, LOC_UPDT_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_UPDT_TIME ACC_UPDT_TIME = ACC_UPDT_TIME + LOC_UPDT_TIME END SUBROUTINE UPDATE_UPDT_TIME SUBROUTINE UPDATE_UPDT_TIME_OUT(LOC_UPDT_TIME_OUT) DOUBLE PRECISION, INTENT(IN) :: LOC_UPDT_TIME_OUT ACC_UPDT_TIME_OUT = ACC_UPDT_TIME_OUT + LOC_UPDT_TIME_OUT END SUBROUTINE UPDATE_UPDT_TIME_OUT SUBROUTINE UPDATE_RMB_TIME(LOC_RMB_TIME) DOUBLE PRECISION, INTENT(IN) :: LOC_RMB_TIME ACC_RMB_TIME = ACC_RMB_TIME + LOC_RMB_TIME END SUBROUTINE UPDATE_RMB_TIME SUBROUTINE UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME) INTEGER, INTENT(IN) :: INODE DOUBLE PRECISION, INTENT(IN) :: LOC_PROMOTING_TIME ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & LOC_PROMOTING_TIME END SUBROUTINE UPDATE_PROMOTING_TIME SUBROUTINE UPDATE_FLOP_STATS_CB_PROMOTE(COST, NIV) DOUBLE PRECISION :: COST INTEGER :: NIV IF (NIV.EQ.1) THEN !$OMP CRITICAL(cb_flop_cost_pro_cri) FLOP_CB_PROMOTE = FLOP_CB_PROMOTE + COST !$OMP END CRITICAL(cb_flop_cost_pro_cri) ELSE !$OMP CRITICAL(acc_cb_flop_cost_pro_cri) ACC_FLOP_CB_PROMOTE = ACC_FLOP_CB_PROMOTE + COST !$OMP END CRITICAL(acc_cb_flop_cost_pro_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_CB_PROMOTE SUBROUTINE UPDATE_FLOP_STATS_CB_DEMOTE(COST, NIV) DOUBLE PRECISION :: COST INTEGER :: NIV IF (NIV.EQ.1) THEN !$OMP CRITICAL(cb_flop_cost_dem_cri) FLOP_CB_DEMOTE = FLOP_CB_DEMOTE + COST !$OMP END CRITICAL(cb_flop_cost_dem_cri) ELSE !$OMP CRITICAL(acc_cb_flop_cost_dem_cri) ACC_FLOP_CB_DEMOTE = ACC_FLOP_CB_DEMOTE + COST !$OMP END CRITICAL(acc_cb_flop_cost_dem_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_CB_DEMOTE SUBROUTINE UPDATE_FLOP_STATS_DEMOTE(LR_B, NIV, REC_ACC) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER(8) :: M,N,K INTEGER :: NIV DOUBLE PRECISION :: HR_COST,BUILDQ_COST LOGICAL, OPTIONAL :: REC_ACC M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K,8) HR_COST = dble(4_8*K*K*K/3_8 + 4_8*K*M*N - 2_8*(M+N)*K*K) IF (LR_B%ISLR) THEN BUILDQ_COST = dble(4_8*K*K*M - K*K*K) ELSE BUILDQ_COST = 0.0d0 END IF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_DEMOTE = FLOP_DEMOTE + HR_COST + BUILDQ_COST IF (present(REC_ACC)) THEN IF (REC_ACC) THEN FLOP_REC_ACC = FLOP_REC_ACC + HR_COST+BUILDQ_COST ENDIF ENDIF !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + (HR_COST + BUILDQ_COST) IF (present(REC_ACC)) THEN IF (REC_ACC) THEN ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC +HR_COST+BUILDQ_COST ENDIF ENDIF !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_DEMOTE SUBROUTINE UPDATE_FLOP_STATS_REC_ACC(LR_B, NIV, K1, K2, BUILDQ1) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER,INTENT(IN) :: NIV, K1, K2 LOGICAL,INTENT(IN) :: BUILDQ1 INTEGER(8) :: M,N,K DOUBLE PRECISION :: HR_COST, BUILDQ_COST, GS_COST, UPDT_COST, & TOT_COST M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K - K1,8) GS_COST = dble((4_8*(K1)+1_8)*M*K2) HR_COST = dble(4_8*K*K*K/3_8 + 4_8*K*M*K2 - 2_8*(M+K2)*K*K) IF (BUILDQ1) THEN BUILDQ_COST = dble(4_8*K*K*M - K*K*K) UPDT_COST = dble(2_8*K*K2*N) ELSE BUILDQ_COST = 0.0d0 UPDT_COST = 0.0d0 ENDIF TOT_COST = BUILDQ_COST + HR_COST + GS_COST + UPDT_COST IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_DEMOTE = FLOP_DEMOTE + TOT_COST FLOP_REC_ACC = FLOP_REC_ACC + TOT_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + TOT_COST ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + TOT_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_REC_ACC SUBROUTINE UPDATE_FLOP_STATS_PANEL(NFRONT, NPIV, NIV, SYM) INTEGER :: NFRONT, NPIV, NIV, SYM DOUBLE PRECISION :: COST_PANEL, COST_TRSM IF (SYM.EQ.0) THEN COST_TRSM = dble(2 * NPIV-1) * dble(NPIV) & * dble(NFRONT-NPIV) COST_PANEL = dble(NPIV) * dble(NPIV - 1) & * dble(4 * NPIV + 1)/dble(6) ELSE COST_TRSM = dble(NPIV) * dble(NPIV) * dble(NFRONT-NPIV) COST_PANEL = dble(NPIV) * dble(NPIV - 1) & * dble(2 * NPIV + 1)/dble(6) ENDIF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_PANEL = FLOP_PANEL + COST_PANEL FLOP_TRSM = FLOP_TRSM + COST_TRSM !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_PANEL = ACC_FLOP_PANEL + COST_PANEL ACC_FLOP_TRSM = ACC_FLOP_TRSM + COST_TRSM !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_PANEL SUBROUTINE UPDATE_FLOP_STATS_TRSM(LRB, NIV, LorU, K470) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: NIV, LorU, K470 DOUBLE PRECISION :: LR_FLOP_COST, FR_FLOP_COST IF (LorU.EQ.0) THEN FR_FLOP_COST = dble(LRB%M)*dble(LRB%N)*dble(LRB%N) IF (LRB%ISLR) THEN LR_FLOP_COST = dble(LRB%K)*dble(LRB%N)*dble(LRB%N) ELSE LR_FLOP_COST = FR_FLOP_COST ENDIF ELSE IF (K470.EQ.1) THEN FR_FLOP_COST = dble(LRB%M-1)*dble(LRB%N)*dble(LRB%N) ELSE FR_FLOP_COST = dble(LRB%M-1)*dble(LRB%M)*dble(LRB%N) ENDIF IF (LRB%ISLR) THEN IF (K470.EQ.1) THEN LR_FLOP_COST = dble(LRB%N-1)*dble(LRB%N)*dble(LRB%K) ELSE LR_FLOP_COST = dble(LRB%M-1)*dble(LRB%M)*dble(LRB%K) ENDIF ELSE LR_FLOP_COST = FR_FLOP_COST ENDIF ENDIF IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_FR_TRSM = FLOP_FR_TRSM + FR_FLOP_COST FLOP_LR_TRSM = FLOP_LR_TRSM + LR_FLOP_COST LR_FLOP_GAIN = LR_FLOP_GAIN + FR_FLOP_COST & - LR_FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_FR_TRSM = ACC_FLOP_FR_TRSM + FR_FLOP_COST ACC_FLOP_LR_TRSM = ACC_FLOP_LR_TRSM + LR_FLOP_COST ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + FR_FLOP_COST & - LR_FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) END IF END SUBROUTINE UPDATE_FLOP_STATS_TRSM SUBROUTINE UPDATE_FLOP_STATS_LRB_PRODUCT(LRB1, LRB2, TRANSB1, & TRANSB2, NIV, COMPRESS_MID_PRODUCT, RANK_IN, BUILDQ, & IS_DIAG, K480, REC_ACC_IN) !$ USE OMP_LIB TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 CHARACTER(len=1), INTENT(IN) :: TRANSB1, TRANSB2 LOGICAL, INTENT(IN), OPTIONAL :: BUILDQ, IS_DIAG, REC_ACC_IN INTEGER, INTENT(IN), OPTIONAL :: NIV, RANK_IN, & COMPRESS_MID_PRODUCT, K480 LOGICAL :: REC_ACC DOUBLE PRECISION :: LR_FLOP_COST, LR_FLOP_COST_OUT, FR_FLOP_COST DOUBLE PRECISION :: HR_COST, BUILDQ_COST DOUBLE PRECISION :: M1,N1,K1,M2,N2,K2,RANK CHARACTER(len=2) :: PROD, TRANS IF(present(K480).AND.present(REC_ACC_IN)) THEN IF (K480.GE.4) THEN REC_ACC = REC_ACC_IN ELSE REC_ACC = .FALSE. ENDIF ELSE REC_ACC = .FALSE. ENDIF 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) IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==0)) THEN PROD = '00' ELSE IF ((LRB1%LRFORM==1).AND.(LRB2%LRFORM==0)) THEN PROD = '10' ELSE IF ((LRB1%LRFORM==0).AND.(LRB2%LRFORM==1)) THEN PROD = '01' ELSE PROD = '11' END IF IF ((TRANSB1=='N').AND.(TRANSB2=='N')) THEN TRANS = 'NN' ELSE IF ((TRANSB1=='T').AND.(TRANSB2=='N')) THEN TRANS = 'TN' ELSE IF ((TRANSB1=='N').AND.(TRANSB2=='T')) THEN TRANS = 'NT' ELSE TRANS = 'TT' END IF LR_FLOP_COST_OUT = 0.0D0 HR_COST = 0.0D0 BUILDQ_COST = 0.0D0 SELECT CASE (PROD) CASE('00') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*M1*N2*N1 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*M1*N2*N1 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*M1*M2*N1 CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 LR_FLOP_COST = 2.0D0*N1*M2*M1 END SELECT CASE('10') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*K1*N2*N1 + 2.0D0*M1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K1 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*K1*N2*M1 + 2.0D0*N1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K1 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*K1*M2*N1 + 2.0D0*M1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K1 CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 LR_FLOP_COST = 2.0D0*K1*M2*M1 + 2.0D0*N1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K1 END SELECT CASE('01') SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 LR_FLOP_COST = 2.0D0*M1*K2*N1 + 2.0D0*M1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K2 CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 LR_FLOP_COST = 2.0D0*N1*K2*M1 + 2.0D0*N1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K2 CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 LR_FLOP_COST = 2.0D0*M1*K2*N1 + 2.0D0*M1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K2 CASE('TT') FR_FLOP_COST = 2*N1*M2*M1 LR_FLOP_COST = 2.0D0*N1*K2*M1 + 2.0D0*N1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K2 END SELECT CASE('11') IF (COMPRESS_MID_PRODUCT.GE.1) THEN HR_COST = 4.0D0*RANK*RANK*RANK/3.0D0 + & 4.0D0*RANK*K1*K2 - & 2.0D0*(K1+K2)*RANK*RANK IF (BUILDQ) THEN BUILDQ_COST = 4.0D0*RANK*RANK*K1 - RANK*RANK*RANK ENDIF ENDIF SELECT CASE (TRANS) CASE('NN') FR_FLOP_COST = 2.0D0*M1*N2*N1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*RANK + 2.0D0*K2*N2*RANK + & 2.0D0*M1*N2*RANK LR_FLOP_COST_OUT = 2.0D0*M1*N2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*K2 + 2.0D0*M1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*N2*K2 + 2.0D0*M1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*N2*K1 ENDIF ENDIF CASE('TN') FR_FLOP_COST = 2.0D0*N1*N2*M1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*RANK + 2.0D0*K2*N2*RANK + & 2.0D0*N1*N2*RANK LR_FLOP_COST_OUT = 2.0D0*N1*N2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*K2 + 2.0D0*N1*N2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N2*K2 + 2.0D0*N1*N2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*N2*K1 ENDIF ENDIF CASE('NT') FR_FLOP_COST = 2.0D0*M1*M2*N1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*RANK + 2.0D0*K2*M2*RANK + & 2.0D0*M1*M2*RANK LR_FLOP_COST_OUT = 2.0D0*M1*M2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M1*K2 + 2.0D0*M1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*N1 + & 2.0D0*K1*M2*K2 + 2.0D0*M1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*M1*M2*K1 ENDIF ENDIF CASE('TT') FR_FLOP_COST = 2.0D0*N1*M2*M1 IF ((COMPRESS_MID_PRODUCT.GE.1).AND.BUILDQ) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*RANK + 2.0D0*K2*M2*RANK + & 2.0D0*N1*M2*RANK LR_FLOP_COST_OUT = 2.0D0*N1*M2*RANK ELSE IF (K1 .GE. K2) THEN LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*N1*K2 + 2.0D0*N1*M2*K2 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K2 ELSE LR_FLOP_COST = 2.0D0*K1*K2*M1 + & 2.0D0*K1*M2*K2 + 2.0D0*N1*M2*K1 LR_FLOP_COST_OUT = 2.0D0*N1*M2*K1 ENDIF ENDIF END SELECT END SELECT IF (present(IS_DIAG)) THEN IF (IS_DIAG) THEN FR_FLOP_COST = FR_FLOP_COST/2.0D0 LR_FLOP_COST = LR_FLOP_COST/2.0D0 ENDIF ENDIF IF (present(K480)) THEN IF (K480.GE.3) THEN LR_FLOP_COST = LR_FLOP_COST - LR_FLOP_COST_OUT LR_FLOP_COST_OUT = 0.0D0 IF (REC_ACC) THEN IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) FLOP_REC_ACC = FLOP_REC_ACC + LR_FLOP_COST & + HR_COST + BUILDQ_COST FLOP_DEMOTE = FLOP_DEMOTE + LR_FLOP_COST & + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + LR_FLOP_COST & + HR_COST + BUILDQ_COST ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + LR_FLOP_COST & + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF ENDIF ENDIF ENDIF IF (.NOT.REC_ACC) THEN IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) LR_FLOP_GAIN = LR_FLOP_GAIN + FR_FLOP_COST - LR_FLOP_COST FLOP_FR_UPDT = FLOP_FR_UPDT + FR_FLOP_COST FLOP_LR_UPDT = FLOP_LR_UPDT + LR_FLOP_COST FLOP_LR_UPDT_OUT = FLOP_LR_UPDT_OUT + LR_FLOP_COST_OUT FLOP_DEMOTE = FLOP_DEMOTE + HR_COST + BUILDQ_COST FLOP_RMB = FLOP_RMB + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + & FR_FLOP_COST - LR_FLOP_COST ACC_FLOP_FR_UPDT = ACC_FLOP_FR_UPDT + FR_FLOP_COST ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + LR_FLOP_COST ACC_FLOP_LR_UPDT_OUT = ACC_FLOP_LR_UPDT_OUT + & LR_FLOP_COST_OUT ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + HR_COST + BUILDQ_COST ACC_FLOP_RMB = ACC_FLOP_RMB + HR_COST + BUILDQ_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF ENDIF END SUBROUTINE UPDATE_FLOP_STATS_LRB_PRODUCT SUBROUTINE UPDATE_FLOP_STATS_DEC_ACC(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) IF (NIV .EQ. 1) THEN !$OMP CRITICAL(lr_flop_gain_cri) LR_FLOP_GAIN = LR_FLOP_GAIN - FLOP_COST FLOP_LR_UPDT = FLOP_LR_UPDT + FLOP_COST FLOP_LR_UPDT_OUT = FLOP_LR_UPDT_OUT + FLOP_COST FLOP_DEC_ACC = FLOP_DEC_ACC + FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ELSE !$OMP CRITICAL(lr_flop_gain_cri) ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN - FLOP_COST ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + FLOP_COST ACC_FLOP_LR_UPDT_OUT = ACC_FLOP_LR_UPDT_OUT + & FLOP_COST ACC_FLOP_DEC_ACC = ACC_FLOP_DEC_ACC + FLOP_COST !$OMP END CRITICAL(lr_flop_gain_cri) ENDIF END SUBROUTINE UPDATE_FLOP_STATS_DEC_ACC SUBROUTINE UPDATE_FLOPS_STATS_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)) ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + COST_PER_PROC RETURN END SUBROUTINE UPDATE_FLOPS_STATS_ROOT SUBROUTINE INIT_STATS_FRONT(NFRONT,INODE,NASS,NCB) INTEGER,INTENT(IN) :: NFRONT,INODE,NASS,NCB FRONT_L11_BLR_SAVINGS = 0.D0 FRONT_U11_BLR_SAVINGS = 0.D0 FRONT_L21_BLR_SAVINGS = 0.D0 FRONT_U12_BLR_SAVINGS = 0.D0 LR_FLOP_GAIN = 0.D0 FLOP_CB_DEMOTE = 0.D0 FLOP_CB_PROMOTE = 0.D0 FLOP_FR_UPDT = 0.D0 FLOP_LR_UPDT = 0.D0 FLOP_LR_UPDT_OUT = 0.D0 FLOP_RMB = 0.D0 FLOP_FR_TRSM = 0.D0 FLOP_LR_TRSM = 0.D0 FLOP_DEMOTE = 0.D0 FLOP_DEC_ACC = 0.D0 FLOP_REC_ACC = 0.D0 FLOP_PANEL = 0.D0 FLOP_TRSM = 0.D0 END SUBROUTINE INIT_STATS_FRONT SUBROUTINE INIT_STATS_GLOBAL(id) use ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id ACC_MRY_CB_GAIN = 0.D0 ACC_MRY_CB_FR = 0.D0 ACC_FLOP_CB_DEMOTE = 0.D0 ACC_FLOP_CB_PROMOTE = 0.D0 ACC_FLOP_FR_FACTO = 0.D0 ACC_FLOP_LR_FACTO = 0.D0 ACC_FLOP_FR_UPDT = 0.D0 ACC_FLOP_LR_UPDT = 0.D0 ACC_FLOP_LR_UPDT_OUT = 0.D0 ACC_FLOP_RMB = 0.D0 ACC_FLOP_FR_TRSM = 0.D0 ACC_FLOP_LR_TRSM = 0.D0 ACC_FLOP_DEMOTE = 0.D0 ACC_FLOP_TRSM = 0.D0 ACC_FLOP_DEC_ACC = 0.D0 ACC_FLOP_REC_ACC = 0.D0 ACC_FLOP_PANEL = 0.D0 ACC_FLOP_FRFRONTS = 0.D0 ACC_FLOP_FR_SOLVE = 0.D0 ACC_FLOP_LR_SOLVE = 0.D0 ACC_LR_FLOP_GAIN = 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 ACC_FR_MRY = 0.D0 GLOBAL_BLR_SAVINGS = 0.D0 ACC_UPDT_TIME = 0.D0 ACC_UPDT_TIME_OUT = 0.D0 ACC_RMB_TIME = 0.D0 ACC_PROMOTING_TIME = 0.D0 ACC_DEMOTING_TIME = 0.D0 ACC_CB_DEMOTING_TIME = 0.D0 ACC_FRPANELS_TIME = 0.0D0 ACC_FAC_I_TIME = 0.0D0 ACC_FAC_MQ_TIME = 0.0D0 ACC_FAC_SQ_TIME = 0.0D0 ACC_FRFRONTS_TIME = 0.0D0 ACC_TRSM_TIME = 0.D0 ACC_LR_MODULE_TIME = 0.D0 CNT_NODES = 0 STEP_STATS => id%STEP END SUBROUTINE INIT_STATS_GLOBAL SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NCB, & SYM, INODE, NELIM) INTEGER,INTENT(IN) :: NASS, NCB, SYM, INODE, NELIM DOUBLE PRECISION :: FRONT_BLR_SAVINGS, FRONT_FR_MRY IF (SYM .GT. 0) THEN FRONT_BLR_SAVINGS = FRONT_L11_BLR_SAVINGS & + FRONT_L21_BLR_SAVINGS FRONT_FR_MRY = dble(NASS-NELIM) * & (dble(NASS-NELIM)+1.D0)/2.D0 & + dble(NASS-NELIM) * dble(NCB+NELIM) ELSE FRONT_BLR_SAVINGS = FRONT_L11_BLR_SAVINGS & + FRONT_L21_BLR_SAVINGS & + FRONT_U11_BLR_SAVINGS & + FRONT_U12_BLR_SAVINGS FRONT_FR_MRY = dble(NASS-NELIM) * dble(NASS-NELIM) & + 2.0D0 * dble(NASS-NELIM) * dble(NCB+NELIM) END IF ACC_FR_MRY = ACC_FR_MRY + FRONT_FR_MRY GLOBAL_BLR_SAVINGS = GLOBAL_BLR_SAVINGS + FRONT_BLR_SAVINGS END SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE1 SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE2(NASS, NFRONT, & SYM, INODE, NELIM) INTEGER,INTENT(IN) :: NASS, NFRONT, SYM, INODE, NELIM IF (SYM .GT. 0) THEN ACC_FR_MRY = ACC_FR_MRY + & dble(NASS-NELIM) * & (dble(NASS-NELIM)+1.D0)/2.D0 & + dble(NASS-NELIM) * dble(NFRONT-NASS+NELIM) ELSE ACC_FR_MRY = ACC_FR_MRY + & dble(NASS-NELIM) * dble(NASS-NELIM) & + 2.0D0 * dble(NASS-NELIM) * dble(NFRONT-NASS+NELIM) ENDIF END SUBROUTINE STATS_COMPUTE_MRY_FRONT_TYPE2 SUBROUTINE STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, & SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS) INTEGER,INTENT(IN) :: NROW, NCB, SYM, NIV, INODE, & FRONT_CB_BLR_SAVINGS DOUBLE PRECISION :: MRY_CB_FR IF (SYM==0) THEN MRY_CB_FR = dble(NCB)*dble(NROW) ELSE MRY_CB_FR = dble(NCB-NROW)*dble(NROW) + & dble(NROW)*dble(NROW+1)/2.D0 ENDIF ACC_MRY_CB_FR = ACC_MRY_CB_FR + MRY_CB_FR ACC_MRY_CB_GAIN = ACC_MRY_CB_GAIN + FRONT_CB_BLR_SAVINGS END SUBROUTINE STATS_COMPUTE_MRY_FRONT_CB SUBROUTINE STATS_STORE_BLR_PANEL_MRY(BLR_PANEL, NB_INASM, & NB_INCB, DIR, NIV) INTEGER,INTENT(IN) :: NB_INASM, NB_INCB, NIV TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(NB_INASM+NB_INCB) CHARACTER(len=1) :: DIR INTEGER :: I IF (NB_INASM.GT.0.AND.DIR .EQ.'V') THEN ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + & dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N) ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N) ENDIF DO I = 1 , NB_INASM ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + & dble(2)*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) IF (BLR_PANEL(I)%ISLR) THEN ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(4)*(dble(BLR_PANEL(I)%M)+dble(BLR_PANEL(I)%N))* & dble(BLR_PANEL(I)%K) IF (DIR .EQ. 'H') THEN IF (NIV .EQ. 1) THEN FRONT_U11_BLR_SAVINGS = & FRONT_U11_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ELSE IF (NIV .EQ. 1) THEN FRONT_L11_BLR_SAVINGS = & FRONT_L11_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M) + dble(BLR_PANEL(I)%N ) ENDIF ENDIF ELSE ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + & dble(2)*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) ENDIF END DO DO I = NB_INASM + 1 , NB_INASM + NB_INCB IF (BLR_PANEL(I)%ISLR) THEN IF (DIR .EQ. 'H') THEN IF (NIV .EQ. 1) THEN FRONT_U12_BLR_SAVINGS = & FRONT_U12_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ELSE IF (NIV .EQ. 1) THEN FRONT_L21_BLR_SAVINGS = & FRONT_L21_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ELSE GLOBAL_BLR_SAVINGS = & GLOBAL_BLR_SAVINGS + & dble( BLR_PANEL(I)%M ) * dble ( BLR_PANEL(I)%N ) - & dble( BLR_PANEL(I)%K ) * & dble( BLR_PANEL(I)%M + BLR_PANEL(I)%N ) ENDIF ENDIF END IF END DO END SUBROUTINE STATS_STORE_BLR_PANEL_MRY SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE1( NFRONT, NASS, NPIV, & KEEP50, INODE) INTEGER,INTENT(IN) :: NFRONT, KEEP50, NASS, NPIV, INODE DOUBLE PRECISION :: FLOP_FR_FACTO CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & KEEP50, 1, FLOP_FR_FACTO) ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO ACC_LR_FLOP_GAIN = ACC_LR_FLOP_GAIN + LR_FLOP_GAIN ACC_FLOP_FR_UPDT = ACC_FLOP_FR_UPDT + FLOP_FR_UPDT ACC_FLOP_LR_UPDT = ACC_FLOP_LR_UPDT + FLOP_LR_UPDT ACC_FLOP_LR_UPDT_OUT= ACC_FLOP_LR_UPDT_OUT+ FLOP_LR_UPDT_OUT ACC_FLOP_RMB = ACC_FLOP_RMB + FLOP_RMB ACC_FLOP_FR_TRSM = ACC_FLOP_FR_TRSM + FLOP_FR_TRSM ACC_FLOP_LR_TRSM = ACC_FLOP_LR_TRSM + FLOP_LR_TRSM ACC_FLOP_DEMOTE = ACC_FLOP_DEMOTE + FLOP_DEMOTE ACC_FLOP_CB_DEMOTE = ACC_FLOP_CB_DEMOTE + FLOP_CB_DEMOTE ACC_FLOP_CB_PROMOTE = ACC_FLOP_CB_PROMOTE + FLOP_CB_PROMOTE ACC_FLOP_DEC_ACC = ACC_FLOP_DEC_ACC + FLOP_DEC_ACC ACC_FLOP_REC_ACC = ACC_FLOP_REC_ACC + FLOP_REC_ACC ACC_FLOP_TRSM = ACC_FLOP_TRSM + FLOP_TRSM ACC_FLOP_PANEL = ACC_FLOP_PANEL + FLOP_PANEL END SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE1 SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE2( NFRONT, NASS, & KEEP50, INODE, NELIM) INTEGER,INTENT(IN) :: NFRONT, KEEP50, NASS, INODE, NELIM DOUBLE PRECISION :: FLOP_FR_FACTO CALL MUMPS_GET_FLOPS_COST(NFRONT, NASS-NELIM, NASS, & KEEP50, 2, FLOP_FR_FACTO) ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO END SUBROUTINE STATS_COMPUTE_FLOP_FRONT_TYPE2 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_FR_FACTO NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP_FR_FACTO = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP_FR_FACTO = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF ACC_FLOP_FR_FACTO = ACC_FLOP_FR_FACTO + FLOP_FR_FACTO END SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2 SUBROUTINE UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, SYM, & NIV) INTEGER, INTENT(IN) :: NFRONT, NPIV, NASS, SYM, NIV DOUBLE PRECISION :: FLOP_FRFRONTS, FLOP_SOLVE CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP_FRFRONTS) ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + FLOP_FRFRONTS FLOP_SOLVE = dble(NASS)*dble(NASS) + & dble(NFRONT-NASS)*dble(NASS) IF (SYM.EQ.0) FLOP_SOLVE = 2.0D0*FLOP_SOLVE ACC_FLOP_FR_SOLVE = ACC_FLOP_FR_SOLVE + FLOP_SOLVE ACC_FLOP_LR_SOLVE = ACC_FLOP_LR_SOLVE + FLOP_SOLVE END SUBROUTINE UPDATE_FLOP_STATS_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_FRFRONTS NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP_FRFRONTS = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP_FRFRONTS = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF ACC_FLOP_FRFRONTS = ACC_FLOP_FRFRONTS + FLOP_FRFRONTS END SUBROUTINE UPD_FLOP_FRFRONT_SLAVE SUBROUTINE COMPUTE_GLOBAL_GAINS(NB_ENTRIES_FACTOR, & FLOP_NUMBER, NIV, PROKG, MPG) INTEGER(KIND=8), INTENT(IN) :: NB_ENTRIES_FACTOR INTEGER, INTENT(IN) :: NIV, MPG LOGICAL, INTENT(IN) :: PROKG DOUBLE PRECISION , INTENT(IN) :: FLOP_NUMBER 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 (ACC_FR_MRY .EQ. 0) THEN GLOBAL_MRY_LPRO_COMPR = 100.0D0 ELSE GLOBAL_MRY_LPRO_COMPR = 100.0D0 * & GLOBAL_BLR_SAVINGS/ACC_FR_MRY ENDIF IF (ACC_MRY_CB_FR .EQ. 0) THEN ACC_MRY_CB_FR = 100.0D0 END IF IF (NB_ENTRIES_FACTOR.EQ.0) THEN FACTOR_PROCESSED_FRACTION = 100.0D0 GLOBAL_MRY_LTOT_COMPR = 100.0D0 ELSE FACTOR_PROCESSED_FRACTION = 100.0D0 * & ACC_FR_MRY/dble(NB_ENTRIES_FACTOR) GLOBAL_MRY_LTOT_COMPR = & 100.0D0*GLOBAL_BLR_SAVINGS/dble(NB_ENTRIES_FACTOR) ENDIF TOTAL_FLOP = FLOP_NUMBER ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN & + ACC_FLOP_DEMOTE RETURN END SUBROUTINE COMPUTE_GLOBAL_GAINS SUBROUTINE SAVEandWRITE_GAINS(LOCAL, K489, DKEEP, N, & DEPTH, BCKSZ, NASSMIN, NFRONTMIN, SYM, K486, & K472, K475, K478, K480, K481, K483, K484, K485, K467, & NBTREENODES, NPROCS, MPG, PROKG) INTEGER, INTENT(IN) :: LOCAL,K489,N,DEPTH,BCKSZ,NASSMIN, & NFRONTMIN, K486, NBTREENODES, MPG, K467, & K472, K475, K478, K480, K481, K483, K484, K485, SYM, NPROCS 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)') & ' Settings for Block Low-Rank (BLR) are :' WRITE(MPG,'(A)') ' BLR algorithm characteristics :' WRITE(MPG,'(A,A)') ' Variant used: FSCU ', & '(Factor-Solve-Compress-Update)' SELECT CASE (K489) CASE (0) CASE (1) WRITE(MPG,'(A)') & ' Experimental CB compression (for stats only)' CASE DEFAULT WRITE(*,*)' Internal error K489=',K489 CALL MUMPS_ABORT() END SELECT IF (K472.EQ.0) THEN WRITE(MPG,'(A,A,I4)') ' Target BLR block size (fixed)', & ' =', & BCKSZ ELSE WRITE(MPG,'(A,A,I4,A,I4)') & ' Target BLR block size (variable)', & ' =', & 128, ' -', BCKSZ ENDIF WRITE(MPG,'(A,A,ES8.1)') ' RRQR precision (epsilon) ', & ' =', & 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)') & ' 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(ACC_FLOP_LR_FACTO+ACC_FLOP_FRFRONTS) DKEEP(61)=dble(100*(ACC_FLOP_LR_FACTO+ & ACC_FLOP_FRFRONTS) /TOTAL_FLOP) IF (PROK) THEN WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' Total theoretical full-rank OPC (i.e. FR OPC) =' & ,TOTAL_FLOP,' (',100*TOTAL_FLOP/TOTAL_FLOP,'%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' Total effective OPC (% FR OPC) =' & ,ACC_FLOP_LR_FACTO+ACC_FLOP_FRFRONTS,' (' &,100*(ACC_FLOP_LR_FACTO+ACC_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.1.2/src/zsol_fwd.F0000664000175000017500000001224513164366265015471 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, & NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, 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_OOC IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB, LNA INTEGER SLAVEF, MYLEAF, COMM, MYID INTEGER INFO( 40 ), 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 NA( LNA ), NE_STEPS( KEEP(28) ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK_S(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 #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8), intent(inout) :: RHSCOMP(NRHS,LRHSCOMP) #else COMPLEX(kind=8), intent(inout) :: RHSCOMP(LRHSCOMP,NRHS) #endif LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGSOU, DUMMY(1) LOGICAL FLAG INTEGER NBFIN, MYROOT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE INTEGER I INTEGER III, NBROOT,LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 DO I = 1, KEEP(28) NSTK_S(I) = NE_STEPS(I) ENDDO PTRICB = 0 CALL MUMPS_INIT_POOL_DIST(N, LEAF, MYID, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID, & SLAVEF, NA, LNA, KEEP, STEP, & PROCNODE_STEPS) NBFIN = SLAVEF IF ( MYROOT .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 MYLEAF = LEAF - 1 III = 1 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, III, 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 .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_SOLVE_NODE( INODE, BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, III, 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, & MYROOT, INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 .OR. 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.1.2/src/dmumps_save_restore_files.F0000664000175000017500000000071313164366264021106 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE DMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE DMUMPS_SAVE_FILES_RETURN MUMPS_5.1.2/src/ztype3_root.F0000664000175000017500000012725113164366265016147 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_ASS_ROOT( NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) IMPLICIT NONE 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 IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON DO J = 1, NCOL_SON-NSUPCOL VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) = & VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'zmumps_root.h' INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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))) 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, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) NBPROCFILS( STEP(IROOT) ) = -1 #if ! defined(NO_XXNBPR) KEEP(121) = -1 #endif IF (IFLAG.LT.0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT)) - 1 #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) - 1 #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN #endif 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(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 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, A( PTRR( STEP(ISON)) + 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, A( PTRR( STEP(ISON)) + 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) 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_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, A( PTRR(STEP(ISON)) + 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, root%RG2L_COL, & 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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 ) IMPLICIT NONE INCLUDE 'zmumps_root.h' 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 ) 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 & ) IMPLICIT NONE INCLUDE 'zmumps_root.h' 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 ) IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE ( ZMUMPS_ROOT_STRUC ):: root INTEGER N, IROOT, INFO(40), KEEP(500) INTEGER FILS( N ) INTEGER INODE, I, allocok IF ( associated( root%RG2L_ROW ) ) DEALLOCATE( root%RG2L_ROW ) IF ( associated( root%RG2L_COL ) ) DEALLOCATE( root%RG2L_COL ) 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 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, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IMPLICIT NONE INCLUDE 'zmumps_root.h' 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 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 ) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N ) 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 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 RETURN ENDIF 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, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, 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 RETURN END SUBROUTINE ZMUMPS_ROOT_ALLOC_STATIC SUBROUTINE ZMUMPS_ASM_RHS_ROOT & ( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) IMPLICIT NONE INCLUDE 'zmumps_root.h' 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 MUMPS_5.1.2/src/sfac_process_root2slave.F0000664000175000017500000002577113164366262020501 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE SMUMPS_LOAD USE SMUMPS_OOC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ), 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) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) 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 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)), & SLAVEF ) ) 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 (KEEP(60) .NE. 0) THEN IF (root%yes) THEN IF ( NEW_LOCAL_M .NE. root%SCHUR_MLOC .OR. & NEW_LOCAL_N .NE. root%SCHUR_NLOC ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_PROCESS_ROOT2SLAVE" CALL MUMPS_ABORT() ENDIF ENDIF PTLUST(STEP(IROOT)) = -4444 PTRFAC(STEP(IROOT)) = -4445_8 PTRIST(STEP(IROOT)) = 0 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 ) 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)) 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 ENDIF GOTO 100 ENDIF 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) 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) GOTO 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 ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB2 compress root2slave: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 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(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LREQA KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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)) 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 )) .LE. 0 ) THEN PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 IF (LREQA.GT.0_8) A(PTRAST(STEP(IROOT)): & PTRAST(STEP(IROOT))+LREQA-1_8) = ZERO 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(.FALSE., MYID, N, IPOS_SON, & PAMASTER(STEP(IROOT)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 END IF END IF IF (NEW_LOCAL_M.GT.OLD_LOCAL_M) 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 100 CONTINUE NBPROCFILS(STEP(IROOT))=NBPROCFILS(STEP(IROOT)) + TOT_CONT_TO_RECV #if ! defined(NO_XXNBPR) KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV #endif #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121)) IF ( KEEP(121) .eq. 0 ) THEN #else IF ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN #endif 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(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.1.2/src/mumps_headers.h0000664000175000017500000000573013164366241016533 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 -> reserved 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 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 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=11,XSIZE_OOC_SYM=11,XSIZE_OOC_UNSYM=11, & XSIZE_OOC_NOPANEL=11) 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 S_CB1COMP PARAMETER (S_CB1COMP=314) INTEGER S_ACTIVE, S_ALL, S_NOLCBCONTIG, & S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, & S_NOLCLEANED38, 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,C_FINI=1) INTEGER S_FREE, S_NOTFREE PARAMETER(S_FREE=54321,S_NOTFREE=-123456) INTEGER TOP_OF_STACK 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.1.2/src/dsol_aux.F0000664000175000017500000010511513164366263015455 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) DOUBLE PRECISION W(N), X(N) DOUBLE PRECISION, intent(inout) :: EST 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) 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) 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 ) 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 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) 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) 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) 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)) 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)) 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) # if defined(RHSCOMP_BYROWS) DOUBLE PRECISION, INTENT(INOUT) :: RHSCOMP(NRHS,LRHSCOMP) # else DOUBLE PRECISION, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) # endif INTEGER :: LD_W, FIRST_ROW_W DOUBLE PRECISION :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT #if defined(RHSCOMP_BYROWS) !$OMP PARALLEL DO PRIVATE (ISHIFT, K), IF !$OMP& ((NBROWS) * (JBFIN-JBDEB+1) > KEEP(363)) DO JJ = 0, NBROWS-1 ISHIFT = FIRST_ROW_W+JJ DO K = JBDEB, JBFIN RHSCOMP(K,FIRST_ROW_RHSCOMP+JJ) = & W(ISHIFT+LD_W*(K-JBDEB)) END DO END DO !$OMP END PARALLEL DO #else !$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 #endif 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) # if defined(RHSCOMP_BYROWS) DOUBLE PRECISION, INTENT(INOUT) :: RHSCOMP(NRHS,LRHSCOMP) # else DOUBLE PRECISION, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) # endif DOUBLE PRECISION :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSCOMP_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSCOMP #if defined(RHSCOMP_BYROWS) !$OMP PARALLEL DO PRIVATE(K,ISHIFT,IPOSINRHSCOMP), IF !$OMP& ((JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>KEEP(363)) DO JJ = J1, J2-KEEP(253) ISHIFT = FIRST_ROW_W+JJ-J1 IPOSINRHSCOMP = abs(POSINRHSCOMP_BWD(IW(JJ))) DO K=JBDEB, JBFIN W(ISHIFT+(K-JBDEB)*LD_W) = RHSCOMP(K,IPOSINRHSCOMP) ENDDO ENDDO !$OMP END PARALLEL DO #else !$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 #endif 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(40), 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 MUMPS_5.1.2/src/mumps_pord.c0000664000175000017500000002323313164366240016054 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/src/sfac_process_root2son.F0000664000175000017500000003224313164366262020156 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 40 ) 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 NBPROCFILS(KEEP(28)) 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 ) 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)),SLAVEF) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & SLAVEF ).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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), SLAVEF) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 7 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO #endif ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(ISON)) + 9 + KEEP(IXSZ) ) MSGTAG = BLOC_FACTO_SYM #else MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, 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.1.2/src/dtools.F0000664000175000017500000007652313164366263015155 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 LOGICAL MOVEPTRAST LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR 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 IF (LDLT.EQ.0) THEN SIZECB = int(LCONT,8) * int(LCONT,8) ELSE SIZECB = int(NROW,8) * int(LCONT,8) ENDIF END IF CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZECB ) IF ((SIZECB.EQ.0_8).AND.(KEEP(201).EQ.0)) THEN GOTO 500 ENDIF IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL DMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) 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 ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF(KEEP(201).EQ.0)THEN PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB ELSE PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) - & SIZECB - SIZELU ENDIF MOVEPTRAST = .TRUE. IF(KEEP(201).EQ.0)THEN PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB ELSE PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB & - SIZELU ENDIF ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF(KEEP(201).EQ.0)THEN PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3))-SIZECB ELSE PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZECB-SIZELU ENDIF ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF(KEEP(201).EQ.0)THEN PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB ELSE PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB & - SIZELU ENDIF END IF IPS = IPS + IPSIZE END DO IF ((SIZECB .NE. 0_8).OR.(KEEP(201).NE.0)) THEN IF (KEEP(201).NE.0) THEN DO I=IAPOS, POSFAC - SIZECB - SIZELU - 1_8 A( I ) = A( I + SIZECB + SIZELU) END DO ELSE DO I=IAPOS + SIZELU, POSFAC - SIZECB - 1_8 A( I ) = A( I + SIZECB ) END DO ENDIF END IF ENDIF IF (KEEP(201).NE.0) THEN POSFAC = POSFAC - (SIZECB+SIZELU) LRLU = LRLU + (SIZECB+SIZELU) LRLUS = LRLUS + (SIZECB+SIZELU) - SIZE_INPLACE KEEP8(70) = KEEP8(70) + (SIZECB+SIZELU) - SIZE_INPLACE KEEP8(71) = KEEP8(71) + (SIZECB+SIZELU) - SIZE_INPLACE ELSE POSFAC = POSFAC - SIZECB LRLU = LRLU + SIZECB LRLUS = LRLUS + SIZECB - SIZE_INPLACE KEEP8(70) = KEEP8(70) + SIZECB - SIZE_INPLACE KEEP8(71) = KEEP8(71) + SIZECB - SIZE_INPLACE IF (LRCOMPRESS_PANEL) THEN KEEP8(71) = KEEP8(71) + SIZELU ENDIF ENDIF 500 CONTINUE CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE,KEEP,KEEP8,LRLUS) 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, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) USE DMUMPS_OOC USE DMUMPS_LOAD 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(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) :: LAFAC, 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) 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 )) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS_CB+XXR)) 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_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRAST(STEP(ISON))), LAFAC, 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) 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 ) 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(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), 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+XXI)=LREQI CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXS)=-9999 IW(POSI+XXS+1:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXLR) = LRSTATUS 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 POSALOC = POSA DO I = 1, NROW_L OLDPOS = PTRAST( STEP(ISON)) + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = 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 KEEP8(10) = KEEP8(10) + int(NCOL_L,8) * int(NROW_L,8) 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 KEEP8(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + LREQA 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 & ) 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 ISTCHK = PTRIST(STEP(ISON)) CALL DMUMPS_FREE_BLOCK_CB(.FALSE.,MYID, N, ISTCHK, & PTRAST(STEP(ISON)), & 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_MAX_MEM( KEEP,KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, PERLU_ON, & MEMORY_BYTES ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON INTEGER, INTENT(IN) :: OOC_STRAT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID, N, NELT, NSLAVES, LNA INTEGER(8) :: NA_ELT8, NNZ8 INTEGER(8), INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT) :: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL, MAXS_MIN 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 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 ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MAXS_MIN = KEEP8(14) ELSE MAXS_MIN = KEEP8(12) ENDIF IF ( .NOT. EFF ) THEN IF ( KEEP8(24).EQ.0_8 ) THEN NB_REAL = NB_REAL + MAXS_MIN + & int(PERLU,8)*(MAXS_MIN / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + KEEP8(67) 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 DMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) DMUMPS_LBUFR_BYTES8 = max( DMUMPS_LBUFR_BYTES8, & 100000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF 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(43))-100,8)) NB_BYTES = NB_BYTES + DMUMPS_LBUFR_BYTES8 DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 43 ) * KEEP( 35 )), 8 ) 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 DMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(DMUMPS_LBUF_INT,8) IF ( EFF ) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int(KEEP(225),8) ELSE NB_INT = NB_INT + int(KEEP(15),8) ENDIF ELSE 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(486).NE.0) THEN NB_INT = NB_INT + N8 NB_REAL = NB_REAL + & int(KEEP(127),8)*int(KEEP(488),8) ENDIF END IF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = int( MEMORY_BYTES / 1000000_8 ) + 1 RETURN END SUBROUTINE DMUMPS_MAX_MEM 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_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,COMPRESSCB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL COMPRESSCB DOUBLE PRECISION A(ASIZE) DOUBLE PRECISION M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW DOUBLE PRECISION ZERO,TMP PARAMETER (ZERO=0.0D0) M_ARRAY(1:NMAX) = ZERO APOS = 0_8 IF (COMPRESSCB) 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 (COMPRESSCB) 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) IF (associated(id%IS1)) NB_INT=NB_INT+size(id%IS1) 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%BUFR)) NB_INT=NB_INT+size(id%BUFR) 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%PROCNODE)) NB_INT=NB_INT+size(id%PROCNODE) IF (associated(id%INTARR)) NB_INT=NB_INT+size(id%INTARR) 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_BEFORE_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_BEFORE_L0_OMP) IF (associated(id%IPOOL_AFTER_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_AFTER_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+size(id%DBLARR) IF (associated(id%RHSCOMP)) NB_CMPLX=NB_CMPLX+size(id%RHSCOMP) 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 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_SIZE ) USE DMUMPS_STATIC_PTR_M INTEGER, INTENT(IN) :: THE_SIZE DOUBLE PRECISION, INTENT(IN) :: THE_ADDRESS(THE_SIZE) CALL DMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE)) RETURN END SUBROUTINE DMUMPS_SET_TMP_PTR MUMPS_5.1.2/src/cfac_process_rtnelind.F0000664000175000017500000001062413164366264020171 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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,ND ) USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' 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) 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)), SLAVEF) 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, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, 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(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.1.2/src/dfac_asm_master_m.F0000664000175000017500000017227713164366264017301 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,NBPROCFILS, 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 MUMPS_BUILD_SORT_INDEX_M USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N,LIW,NSTEPS INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 DOUBLE PRECISION, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NBPROCFILS(KEEP(28)), NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) 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 ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE 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 INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8 INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC INTEGER(8) :: SIZFR8 INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM, & IBROT,IORG 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 INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE, OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER, POINTER :: SON_IWPOS INTEGER, POINTER, DIMENSION(:) :: SON_IW DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 COMPRESSCB =.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 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)), & SLAVEF) 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 LREQ_OOC = 0 IF (KEEP(201).EQ.1) 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) 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)),SLAVEF) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF END IF END IF END IF END IF NIV1 = .TRUE. CALL MUMPS_BUILD_SORT_INDEX( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, 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)), & SLAVEF))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) 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 NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF IF (LRLU .LT. LAELL_REQ8) THEN IF (LRLUS .LT. LAELL_REQ8) THEN IF (LPOK) THEN WRITE(LP, * ) ' NOT ENOUGH MEMORY during ASSEMBLY ', & ' MEMORY REQUESTED = ', LAELL_REQ8, & ' AVAILABLE =', LRLUS ENDIF GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 4 after compress ' WRITE(LP, * ) 'IN DMUMPS_FAC_ASM_NIV1' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 + SIZE_ISON_TOP8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 + SIZE_ISON_TOP8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) #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=3000 !$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 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 TOPDIAG = max(KEEP(7), KEEP(8))-1 !$ 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 ) TOPDIAG = max(KEEP(7), KEEP(8), KEEP(57), KEEP(58))-1 !$ 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)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 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_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) 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 COMPRESSCB = & ( SON_IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( SON_IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF 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) THEN K2 = K1 + LSTK - 1 IF (COMPRESSCB) THEN SIZFR8 = (int(LSTK,8)*int(LSTK+1,8))/2_8 ELSE SIZFR8 = int(LSTK,8)*int(LSTK,8) ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * int(LSTK,8) ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) 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.300) !$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) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR8 ELSE LCB = int(LDA_SON,8) * int(K2-K1+1,8) ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL DMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB) ELSE IF (LCB .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, LCB, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & COMPRESSCB & ) 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(SSARBR, MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) 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, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 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 280 CONTINUE INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL_REQ8 - LRLUS, INFO(2)) IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL 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 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 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, & NBPROCFILS, 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 IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(40) 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 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 NBPROCFILS(KEEP(28)), & 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 INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER,I INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL COMPRESSCB INTEGER(8) :: LCB 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 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 !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. COMPRESSCB = .FALSE. ETATASS = 0 IN = INODE NBPROCFILS(STEP(IN)) = 0 NSTEPS = NSTEPS + 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)), & SLAVEF) .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 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)), & SLAVEF) 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)), & SLAVEF) 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) 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) 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) 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) GOTO 275 ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, 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) 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) #if defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) IF ( KEEP(73) .EQ. 0 ) THEN #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 defined(OLD_LOAD_MECHANISM) #if ! defined (CHECK_COHERENCE) ENDIF #endif #endif 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 IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE 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) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 3 after compress ' WRITE(LP, * ) 'IN DMUMPS_FAC_ASM_NIV2' WRITE(LP, * ) 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL8 KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL8 KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = -99999 CALL IS_FRONT_BLR_CANDIDATE(INODE, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), N, LRGROUPS, & IW(IOLDPS+XXLR)) #if defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=-99999 #else CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 = max(int(KEEP(361)/2,8), !$ & (LAELL8+NOMP-1) / NOMP ) !$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 !$ 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 COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) 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) + 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) + A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (NSLSON.EQ.0) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF IF (LCB .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & COMPRESSCB & ) 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, & 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), & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 280 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -9 CALL MUMPS_SET_IERROR(LAELL8-LRLUS, INFO(2)) 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.1.2/src/ssol_matvec.F0000664000175000017500000002357213164366266016167 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(out) :: 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.1.2/src/mumps_common.c0000664000175000017500000000310013164366240016367 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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; } MUMPS_5.1.2/src/cfac_process_message.F0000664000175000017500000010276013164366264020001 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 40 ) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, 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(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,SLAVEF, & 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(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, NBPROCFILS, & N, IW, LIW, A, LA, & 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, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, COMP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, 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, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF) 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)), & SLAVEF ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF)) 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)),SLAVEF) & ) 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 IMPLICIT NONE INCLUDE 'cmumps_root.h' 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(40) 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 NBPROCFILS( KEEP(28) ) 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 ) 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & 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, & NBPROCFILS, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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.1.2/src/cmumps_struc_def.F0000664000175000017500000000070613164366265017203 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zarrowheads.F0000664000175000017500000006766513164366265016213 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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( 40 ) 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 INTEGER(8) :: IPTRI, IPTRR 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), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), SLAVEF ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), SLAVEF ) 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 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), SLAVEF ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), SLAVEF ) 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. 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 ) IMPLICIT NONE INCLUDE 'zmumps_root.h' 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,INEW,JNEW,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 TYPENODE_TMP, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: I1, IA, IIW, IS1, IS, IAS, ISHIFT, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, POINTER, DIMENSION(:,:) :: IW4 ARROW_ROOT = 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 ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER(int(I-1,8)*int(root%SCHUR_LLD,8)+1_8: & int(I-1,8)*int(root%SCHUR_LLD,8)+int(root%SCHUR_MLOC,8))= & ZERO ENDDO ENDIF 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 DO 120 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 GOTO 120 END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF 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 ENDIF ENDIF IARR = abs( ISEND ) ISTEP = abs( STEP(IARR) ) TYPENODE_TMP = MUMPS_TYPENODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE = MUMPS_PROCNODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & SLAVEF ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF (TYPENODE_TMP.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) 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 IF ( TYPENODE_TMP .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPENODE_TMP .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 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 )/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 END IF 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 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPENODE_TMP .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 IIW = IS1 + ISHIFT + 2_8 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = 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 ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 .OR. .TRUE.) & .AND. IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF (MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) == 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 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)) END IF 120 CONTINUE 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 & ) IMPLICIT NONE INCLUDE 'zmumps_root.h' 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 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 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) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I=1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC)=ZERO ENDDO ENDIF 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)))), & SLAVEF ) .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 .OR. .TRUE.) & .AND. IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) 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 MUMPS_5.1.2/src/crank_revealing.F0000664000175000017500000000477713164366264017006 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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(40), MPG KEEP(19)=0 RETURN END SUBROUTINE CMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE CMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL,KEEP,MPG,INFO) IMPLICIT NONE INTEGER KEEP(500), MPG, INFO(40), ICNTL(40) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 16 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 (ICNLT(9)=1) ' ENDIF ENDIF 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.1.2/src/dana_mtrans.F0000664000175000017500000007675413164366266016151 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/zsol_c.F0000664000175000017500000026350313164366265015140 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, PTR_RHS_ROOT, LPTR_RHS_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 , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS & ) USE ZMUMPS_OOC USE MUMPS_SOL_ES IMPLICIT NONE INCLUDE 'zmumps_root.h' #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(40),INFO(40), KEEP(500) 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)) #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8) :: RHSCOMP(NRHS, LRHSCOMP) #else COMPLEX(kind=8) :: RHSCOMP(LRHSCOMP,NRHS) #endif 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) :: LPTR_RHS_ROOT COMPLEX(kind=8) PTR_RHS_ROOT(LPTR_RHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,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 INTEGER IZERO 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 PARAMETER (IZERO = 0 ) COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mumps_headers.h' 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) :: LPTR_RHS_BOUNDS INTEGER, intent(inout) :: PTR_RHS_BOUNDS (LPTR_RHS_BOUNDS) DOUBLE PRECISION, intent(inout) :: DKEEP(230) 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, DIMENSION(:), ALLOCATABLE :: prun_NA INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP, INODE_PRINC LOGICAL AM1, DO_PRUN LOGICAL Exploit_Sparsity LOGICAL DO_NBSPARSE_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 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 = KEEP(28)+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 IF (.not. allocated(Pruned_SONS)) 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 END IF IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (.not. allocated(TO_PROCESS)) THEN SIZE_TO_PROCESS = KEEP(28) 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 END IF TO_PROCESS(:) = .TRUE. ENDIF 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 MUMPS_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 MUMPS_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 MUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), 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 MUMPS_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), & PTR_RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL MUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, PTR_RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, & 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 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 ZMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE, & FROM_PP & ) ELSE ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), & STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves+nb_prun_roots+2 END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 prun_NA(1) = nb_prun_leaves prun_NA(2) = nb_prun_roots DO I = 1, nb_prun_leaves prun_NA(I+2) = Pruned_Leaves(I) ENDDO DO I = 1, nb_prun_roots prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) ENDDO DEALLOCATE(Pruned_List) DEALLOCATE(Pruned_Leaves) IF (AM1) THEN DEALLOCATE(Pruned_Roots) END IF IF ((Exploit_Sparsity).AND.(nb_prun_roots.EQ.NA(2))) THEN DEALLOCATE(Pruned_Roots) IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) SWITCH_OFF_ES = .TRUE. ENDIF CALL ZMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & Pruned_SONS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & PTR_RHS_ROOT, LPTR_RHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) DEALLOCATE(prun_NA) 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. 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 MUMPS_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 MUMPS_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 MUMPS_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 PTR_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, & PTR_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 (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF 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 ( AM1 ) THEN CALL MUMPS_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 MUMPS_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 MUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL MUMPS_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), & PTR_RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL MUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, PTR_RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, & 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 = IZERO 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 PTR_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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,II) = ZERO #else RHSCOMP(II, K) = ZERO #endif ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN ) THEN SIZE_TO_PROCESS = 1 IF (allocated(TO_PROCESS)) DEALLOCATE(TO_PROCESS) ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) TO_PROCESS(:) = .TRUE. 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, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, DKEEP, & PTR_RHS_ROOT, LPTR_RHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE_BWD, & FROM_PP & ) ELSE ALLOCATE(prun_NA(nb_prun_leaves+nb_prun_roots+2), & STAT=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of prun_na' CALL MUMPS_ABORT() END IF prun_NA(1) = nb_prun_leaves prun_NA(2) = nb_prun_roots DO I = 1, nb_prun_leaves prun_NA(I+2) = Pruned_Leaves(I) ENDDO DO I = 1, nb_prun_roots prun_NA(I+2+nb_prun_leaves) = Pruned_Roots(I) ENDDO 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, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & PTR_RHS_ROOT, LPTR_RHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, TO_PROCESS, SIZE_TO_PROCESS & , PTR_RHS_BOUNDS, LPTR_RHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP) ENDIF #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 #if defined(RHSCOMP_BYROWS) K = min0(10,size(RHSCOMP,2)) IF (LDIAG.EQ.4) K = size(RHSCOMP,2) WRITE (MP,99992) IF (size(RHSCOMP,2).GT.0) & WRITE (MP,99993) (RHSCOMP(1,I),I=1,K) IF (size(RHSCOMP,2).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSCOMP(2,I),I=1,K) #else K = min0(10,size(RHSCOMP,1)) IF (LDIAG.EQ.4) K = size(RHSCOMP,1) 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(prun_NA)) DEALLOCATE (prun_NA) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (first column)'/(1X,1P,5D14.6)) 99994 FORMAT (' RHS (2 nd column)'/(1X,1P,5D14.6)) 99992 FORMAT (//' LEAVING SOLVE (MPI41C) 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) #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8), intent(in) :: RHSCOMP(NCOL_RHSCOMP, LRHSCOMP) #else COMPLEX(kind=8), intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) #endif 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 PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP INTEGER SK38, SK20 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 MUMPS_PROCNODE 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 = N/2 !$ 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)) !$ 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) # else RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) # endif 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) # else RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) # endif 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 = N/2 !$ 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)) !$ 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = RHSCOMP(J,IPOSINRHSCOMP) # else RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) # endif 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 # if defined(RHSCOMP_BYROWS) RHS(I,JCOL_RHS) = RHSCOMP(J,IPOSINRHSCOMP) # else RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) # endif 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 defined(RHSCOMP_BYROWS) IF (LCWORK .LT. NRHS) THEN WRITE(*,*) MYID, & ": Internal error 2 in ZMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF #else 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 #endif IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247))) 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 (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) THEN IPOS = PTRIST(ISTEP)+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV 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 (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) #if defined(RHSCOMP_BYROWS) DO I=1,NPIV II=IROWLIST(I) CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NRHS, MPI_DOUBLE_COMPLEX, & COMM, IERR) IF (LSCAL.AND.KEEP(242).EQ.0) THEN DO J=1,NRHS JCOL_RHS = J+JBEG_RHS-1 RHS(II,JCOL_RHS) = CWORK(J)*SCALING(II) ENDDO ELSE IF ((.NOT. LSCAL).AND.(KEEP(242).EQ.0)) THEN DO J=1,NRHS JCOL_RHS = J+JBEG_RHS-1 RHS(II,JCOL_RHS) = CWORK(J) ENDDO ELSE IF (LSCAL.AND.KEEP(242).NE.0) THEN DO J=1,NRHS JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) RHS(II,JCOL_RHS) = CWORK(J)*SCALING(II) ENDDO ELSE DO J=1,NRHS JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) RHS(II,JCOL_RHS) = CWORK(J) ENDDO ENDIF ENDDO #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 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 #endif 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 defined(RHSCOMP_BYROWS) IF (KEEP(242).EQ.0) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) IF (LSCAL) THEN DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(J,IPOSINRHSCOMP)*SCALING(I) ENDDO ELSE DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(J,IPOSINRHSCOMP) ENDDO ENDIF ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(J,IPOSINRHSCOMP) IF (LSCAL) THEN RHS(I,PERM_RHS(J+JBEG_RHS-1)) = RHS(I,PERM_RHS(J+JBEG_RHS-1))*SCALING(I) ENDIF ENDDO ENDDO ENDIF #else 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) 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) DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF 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)) #if defined(RHSCOMP_BYROWS) DO II=1,NPIV DO J=1, NRHS CWORK(J) = RHSCOMP(J,IPOSINRHSCOMP+II-1) ENDDO CALL MPI_PACK(CWORK(1), NRHS, & MPI_DOUBLE_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO #else DO J=1,NRHS CALL MPI_PACK(RHSCOMP(IPOSINRHSCOMP,J), NPIV, & MPI_DOUBLE_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO #endif 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 #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8), intent(in) :: RHSCOMP (NRHSCOMP_COL,LRHSCOMP) #else COMPLEX(kind=8), intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL) #endif 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 #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)= & RHSCOMP(K,IPOSINRHSCOMP)*SCALING(I) #else RHS_SPARSE_COPY(IZ)= & RHSCOMP(IPOSINRHSCOMP,K)*SCALING(I) #endif ELSE #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)=RHSCOMP(K,IPOSINRHSCOMP) #else RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) #endif 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 #if defined(RHSCOMP_BYROWS) RHS_SPARSE_COPY(IZ)=RHSCOMP(K,IPOSINRHSCOMP) #else RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) #endif 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) 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 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 INTEGER SK38,SK20 INCLUDE 'mumps_headers.h' IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 DO JJ=J1,J1+NPIV-1 K=K+1 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 ) # if defined(RHSCOMP_BYROWS) COMPLEX(kind=8) RHSCOMP( NBRHS_EFF, LRHSCOMP ) # else COMPLEX(kind=8) RHSCOMP( LRHSCOMP, NBRHS_EFF ) # endif 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), & SLAVEF)) 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 ((KEEP(242) .EQ. 0).AND.(KEEP(350).EQ.0)) THEN KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 IPOSINRHSCOMP = POSINRHSCOMP(IW(JJ)) IF (NB_RHSSKIPPED.GT.0) THEN SOL_LOC(KLOC, BEG_RHS:JEMPTY) = ZERO ENDIF IF (LSCAL) THEN # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(1:NBRHS_EFF,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,1:NBRHS_EFF) # endif ELSE # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JEMPTY+1:JEND) = & RHSCOMP(1:NBRHS_EFF,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JEMPTY+1:JEND) = & RHSCOMP(IPOSINRHSCOMP,1:NBRHS_EFF) # endif ENDIF ENDDO ELSE 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+1) .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 # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(JCOL-JEMPTY,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) # endif ELSE # if defined(RHSCOMP_BYROWS) SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(JCOL-JEMPTY,IPOSINRHSCOMP) # else SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) # endif ENDIF ENDDO ENDDO !$OMP END PARALLEL DO ENDIF 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(40), INFO(40) COMPLEX(kind=8), intent(in) :: RHS (LRHS, NCOL_RHS) #if defined(RHSCOMP_BYROWS) COMPLEX(kind=8), intent(out) :: RHSCOMP(NCOL_RHSCOMP, LRHSCOMP) #else COMPLEX(kind=8), intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) #endif 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 SK38, SK20 !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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 #if defined(RHSCOMP_BYROWS) DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP DO K=1, NCOL_RHSCOMP RHSCOMP (K, I) = ZERO ENDDO ENDDO #else DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO #endif 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& FIRSTPRIVATE(BUF_EFFSIZE) 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 #if defined(RHSCOMP_BYROWS) DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP DO K=1, NCOL_RHSCOMP RHSCOMP (K, I) = ZERO ENDDO ENDDO #else DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO #endif ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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)) END IF 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 defined(RHSCOMP_BYROWS) DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSCOMP( K, INDX+JJ-J1 ) = RHS( J, K ) ENDDO ENDDO #else 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(J1,NPIV,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 #endif 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& FIRSTPRIVATE(BUF_EFFSIZE) IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) #if defined(RHSCOMP_BYROWS) RHSCOMP( K, INDX ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE ) #else RHSCOMP( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) #endif 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 #if defined(RHSCOMP_BYROWS) RHSCOMP( K, INDX ) = BUF_RHS( K, I ) #else RHSCOMP( INDX, K ) = BUF_RHS( K, I ) #endif 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 SK38, SK20, IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 SK38, SK20, 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 IF (KEEP(38).NE.0) THEN SK38=STEP(KEEP(38)) ELSE SK38=0 ENDIF IF (KEEP(20).NE.0) THEN SK20=STEP(KEEP(20)) ELSE SK20=0 ENDIF 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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),NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SK38 .OR. ISTEP.EQ.SK20 ) 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 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 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.1.2/src/cfac_driver.F0000664000175000017500000037002313164366266016113 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_CORE USE CMUMPS_LR_STATS USE CMUMPS_LR_DATA_M, only: CMUMPS_BLR_INIT_MODULE, & CMUMPS_BLR_END_MODULE 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 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 C Explicit interface needed because C of "id" derived datatype argument 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 C 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(8) ::KEEP826_SAVE INTEGER(8) K67 INTEGER(8) K68,K69 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF INTEGER CMUMPS_LBUF, CMUMPS_LBUFR_BYTES, CMUMPS_LBUF_INT INTEGER(8) CMUMPS_LBUFR_BYTES8, CMUMPS_LBUF8 INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, NSTEPS, K28, LPOOL, LIW INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 REAL CNTL4 INTEGER MIN_PERLU, MAXIS_ESTIM INTEGER MAXIS INTEGER(8) :: MAXS 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 INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER LIWK, LWK_REAL INTEGER(8) :: LWK C SLAVE: used to determine if proc has the role of a slave LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED C WK_USER_PROVIDED is set to true when workspace WK_USER is provided by user REAL :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2 REAL :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER FRONTWISE C temporary variable for collecting stats from all processors DOUBLE PRECISION :: TMP_GLOBAL_BLR_SAVINGS DOUBLE PRECISION :: TMP_ACC_FR_MRY DOUBLE PRECISION :: TMP_ACC_LR_FLOP_GAIN DOUBLE PRECISION :: TMP_ACC_FLOP_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_PANEL DOUBLE PRECISION :: TMP_ACC_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_ACC_FLOP_LR_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_FR_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_LR_UPDT DOUBLE PRECISION :: TMP_ACC_FLOP_LR_UPDT_OUT DOUBLE PRECISION :: TMP_ACC_FLOP_RMB DOUBLE PRECISION :: TMP_ACC_FLOP_DEC_ACC DOUBLE PRECISION :: TMP_ACC_FLOP_REC_ACC DOUBLE PRECISION :: TMP_ACC_FLOP_FR_UPDT DOUBLE PRECISION :: TMP_ACC_FLOP_DEMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_CB_DEMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_CB_PROMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_FR_FACTO INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_ACC_UPDT_TIME DOUBLE PRECISION :: TMP_ACC_DEMOTING_TIME DOUBLE PRECISION :: TMP_ACC_CB_DEMOTING_TIME DOUBLE PRECISION :: TMP_ACC_PROMOTING_TIME DOUBLE PRECISION :: TMP_ACC_FRPANELS_TIME DOUBLE PRECISION :: TMP_ACC_FAC_I_TIME DOUBLE PRECISION :: TMP_ACC_FAC_MQ_TIME DOUBLE PRECISION :: TMP_ACC_FAC_SQ_TIME DOUBLE PRECISION :: TMP_ACC_TRSM_TIME DOUBLE PRECISION :: TMP_ACC_FRFRONTS_TIME DOUBLE PRECISION :: TMP_ACC_LR_MODULE_TIME 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 C C External references C =================== INTEGER numroc EXTERNAL numroc C Fwd in facto: COMPLEX, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_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 C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS 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 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 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 ) IF ( PROKG .and. KEEP(53).GT.0 ) THEN WRITE(MPG,'(/A,I3)') ' Null space option :', KEEP(19) IF ( KEEP(21) .ne. N ) THEN WRITE( MPG, '(A,I10)') ' Max deficiency : ', KEEP(21) END IF IF ( KEEP(22) .ne. 0 ) THEN WRITE( MPG, '(A,I10)') ' Min deficiency : ', KEEP(22) END IF END IF 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 !Later: .GT. to allow ICNTL(22)=-1 # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(480).NE.0) THEN id%KEEP(480) = 0 IF (PROK) & write(MP,'(A)') & ' MUMPS is not compiled with -DBLR_LUA ', & ' => Resetting KEEP(480) to 0' ENDIF IF (id%KEEP(475).NE.0) THEN id%KEEP(475) = 0 IF (PROK) & write(MP,'(A)') & ' MUMPS is not compiled with -DLRTRSM ', & ' => Resetting KEEP(475) to 0' 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 ) IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & " Internal ERROR with BLR setting " WRITE(MPG,'(A)') " BLR was not activated during ", & " analysis and is requested during factorization. " id%INFO(1)=-900 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(470), 23, MPI_INTEGER, & MASTER, id%COMM, IERR ) 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 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 C 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 C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL(1) = 0.0 C --------------------------------------- IF ( KEEP(50) .eq. 1 ) THEN IF (id%CNTL(1) .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') &' ** Warning : SPD solver called, resetting CNTL(1) to 0.0E0' END IF END IF id%CNTL(1) = ZERO END IF 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 (PROKG) WRITE(MPG,'(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 (PROKG) WRITE(MPG,'(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 (PROKG) WRITE(MPG,'(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 IF ( PROKG ) THEN WRITE( MPG, 172 ) id%NSLAVES, id%ICNTL(22), & id%KEEP8(111), KEEP(126), KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, id%CNTL(1) IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) 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 530 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL)) 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 530 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) 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 530 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,*) 'ERREUR 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)) RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 530 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 -Rank revealing on the Schur (ICNTL(16)/KEEP(19)) C CNTL(6) is used to set SEUIL and SEUIL_LDLT_NIV2 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. C Note that SEUIL* might be reset later in this routine C but only when static pivoting is on C which will be excluded if null pivots or C rank-revealing (RR) is on C ----------------------------------------------- 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) CNTL1 = id%CNTL(1) CALL MPI_BCAST(CNTL1, 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) 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 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).EQ.0) THEN C -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO ELSE C -- RR is on C July 2012 C CNTL(3) is the threshold used in the following C to compute the SEUIL used for postponing pivots to root C SEUIL*CNTL(6) is then the treshold for null pivot detection C (with 0< CNTL(6) <= 1) IF (CNTL3 .LT. ZERO) THEN SEUIL = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN SEUIL = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN SEUIL = N*EPS*ANORMINF ! standard articles ENDIF IF (PROKG) WRITE(MPG,*) & ' ABSOLUTE PIVOT THRESHOLD for rank revealing =',SEUIL ENDIF C After QR with pivoting of root or SVD, diagonal entries C need be analysed to determine null space vectors. C Two strategies are provided : id%DKEEP(9) = SEUIL IF (id%DKEEP(10).LT.MONE) THEN id%DKEEP(10)=MONE ELSEIF((id%DKEEP(10).LE.ONE).AND.(id%DKEEP(10).GE.ZERO)) THEN id%DKEEP(10)=1000.0E0 ENDIF SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN 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 IF (ANORMINF.EQ.ZERO) & CALL CMUMPS_ANORMINF( id , ANORMINF, LSCAL ) IF (KEEP(19).NE.0) THEN C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed. C Pivot rows smaller than DKEEP(1) are directly added to null space C and thus considered as null pivot rows. Thus we define id%DKEEP(1) C relatively to SEUIL (which is based on CNTL(3)) IF (CNTL(6).GT.0.AND.CNTL(6).LT.1) THEN C we want DKEEP(1) < SEUIL id%DKEEP(1) = SEUIL*CNTL(6) ELSE id%DKEEP(1) = SEUIL* 0.01E0 ENDIF ELSE 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 id%DKEEP(1) = 1.0E-5*EPS*ANORMINF ENDIF ENDIF IF (PROKG) WRITE(MPG,*) & ' ZERO PIVOT DETECTION ON, THRESHOLD =',id%DKEEP(1) IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,*) & ' 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 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%NSLAVES) 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 C and in case of rank revealing 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 530 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 C -- Set KEEP(97) and compute static pivoting threshold. 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 ) C WRITE(*,*) id%MYID,': ANORMINF',ANORMINF ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE C WRITE(*,*) 'id%CNTL(4)',id%CNTL(4) 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 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 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C Allocate S on all nodes C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN C In-core MAXS_BASE8=id%KEEP8(12) ELSE C OOC or no factors stored MAXS_BASE8=id%KEEP8(14) ENDIF IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ELSE IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) C If PERLU < 0, we may obtain a C null or negative value of MAXS. IF (MAXS_BASE_RELAXED8 > huge(MAXS)) THEN C id%INFO(1)=-37 C id%INFO(2)=int(MAXS_BASE_RELAXED8/1000000_8) WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ENDIF MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) MAXS = MAXS_BASE_RELAXED8 C Note that in OOC this value of MAXS will be C overwritten if KEEP(96) .NE. 0 or if C ICNTL(23) (that is, KEEP8(4)) is provided. ELSE MAXS = 1_8 MAXS_BASE_RELAXED8 = 1_8 END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF C C If KEEP(96) is provided, C use it without asking questions C IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C C IF (KEEP(96).GT.0) THEN C -- useful mostly for internal testing: C -- we can force in this way a given value C -- of MAXS and forget about other input values C -- such as ICNTL(23) (KEEP8(4)/1E6) C -- that could change MAXS value. MAXS=int(KEEP(96),8) ELSE IF (id%KEEP8(4) .NE. 0_8) THEN C ------------------------- C WE TRY TO USE MEM_ALLOWED (KEEP8(4)/1E6) C ------------------------- C First compute what we have: TOTAL_MBYTES(PERLU) C and TOTAL_BYTES(PERLU) C PERLU_ON = .TRUE. CALL CMUMPS_MAX_MEM( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, & id%KEEP8(28), id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., KEEP(201), & PERLU_ON, TOTAL_BYTES) C C Assuming that TOTAL_BYTES is due to MAXS rather than C to the temporary buffers used for the distribution of C the matrix on the slaves (arrowheads or element distrib), C then we have: C C KEEP8(4)-TOTAL_BYTES is the extra free space C C A simple algorithm to redistribute the extra space: C All extra freedom (it could be negative !) is added to MAXS: MAXS_BASE_RELAXED8=MAXS_BASE_RELAXED8 + & (id%KEEP8(4)-TOTAL_BYTES)/int(KEEP(35),8) IF (MAXS_BASE_RELAXED8 > int(huge(MAXS),8)) THEN WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ELSE IF (MAXS_BASE_RELAXED8 .LE. 0_8) THEN C We need more space in order to at least enough id%INFO(1)=-9 IF ( -MAXS_BASE_RELAXED8 .GT. & int(huge(id%INFO(1)),8) ) THEN WRITE(*,*) "I8: OVERFLOW" CALL MUMPS_ABORT() ENDIF id%INFO(2)=-int(MAXS_BASE_RELAXED8) ELSE MAXS=MAXS_BASE_RELAXED8 ENDIF ENDIF ENDIF ENDIF ! I_AM_SLAVE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF CALL CMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & id%COMM, "effective relaxed size of S =") C Next PROPINFO is there for possible negative C values of MAXS resulting from small MEM_ALLOWED CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN C We jump after the call to LOAD_END and OOC_END since we didn't C called yet OOC_INIT and LOAD_INIT GOTO 530 ENDIF IF ( I_AM_SLAVE ) THEN C ------------------ C Dynamic scheduling C ------------------ CALL CMUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), KEEP(66), 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)-TOTAL_BYTES 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 #if ! defined(OLD_LOAD_MECHANISM) 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)) #endif IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 ! reset space allocated to zero ENDIF #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN 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 ELSE id%S => id%WK_USER(1:id%KEEP8(24)) 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 CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) CALL MUMPS_FDM_INIT('F',NB_ACTIVE_FRONTS_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_ACTIVE_FRONTS_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 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 C ---------------------------------------- IF (KEEP(38).NE.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 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) IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF 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 ) ) 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, id%I_AM_CAND, & id%CANDIDATES) C 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 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 ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) 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), id%S(1), MAXS, & 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, & & id%S(1), MAXS, & 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, & id%S(1), MAXS, 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), & id%S(1), MAXS, 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) TIME 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 slaves 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 integers, since byte is not C a standard datatype. C We now use KEEP(43) and KEEP(44) as estimated at analysis C to allocate appropriate buffer sizes. C C Reception buffer C ---------------- CMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP( 35 ), 8) C ------------------- C Ensure a reasonable C 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 PERLU = KEEP( 12 ) C For hybrid scheduling (strategy 5), Abdou C wants a minimal amount of freedom even for C small/negative PERLU values. 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(43))-100,8)) CMUMPS_LBUFR_BYTES = int( CMUMPS_LBUFR_BYTES8 ) IF (KEEP(48)==5) THEN C Since the buffer is 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 ----------- CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(43)) * real(KEEP(35)), 8 ) 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%NSLAVES ) 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 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 the 2 send buffers 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 CALL CMUMPS_BUF_ALLOC_CB( CMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= CMUMPS_LBUF id%INFO(2)= (CMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error in CMUMPS_BUF_ALLOC_CB' & ,id%INFO(2) ENDIF GO TO 110 END IF C ----------------------------- C Allocate reception buffer and C keep it in the structure C ----------------------------- id%LBUFR_BYTES = CMUMPS_LBUFR_BYTES id%LBUFR = (CMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) IF (associated(id%BUFR)) DEALLOCATE(id%BUFR) ALLOCATE( id%BUFR( id%LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%LBUFR NULLIFY(id%BUFR) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%BFUR(', id%LBUFR,')', IERR ENDIF GO TO 110 END IF C C The buffers are declared INTEGER, because BYTE is not a C standard data type. The sizes are in bytes, so we allocate C a number of INTEGERs. The allocated size in integer is the C size in bytes divided by KEEP(34) C ------------------------------- C Allocate IS. IS will contain C factors and contribution blocks C ------------------------------- C Relax workspace at facto now C PERLU might have been modified reload initial value 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 + 2 * max(PERLU,10) * & ( MAXIS_ESTIM / 100 + 1 ) & ) IF (associated(id%IS)) DEALLOCATE( id%IS ) ALLOCATE( id%IS( MAXIS ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=MAXIS NULLIFY(id%IS) IF (LPOK) THEN WRITE(*,*) id%MYID,': Allocation error for id%IS(',MAXIS,')' ENDIF GO TO 110 END IF LIW = MAXIS C ----------------------- C Allocate PTLUST_S. PTLUST_S C is used by solve later C ----------------------- IF (associated( id%PTLUST_S )) DEALLOCATE(id%PTLUST_S) 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 100 END IF IF (associated( id%PTRFAC )) DEALLOCATE(id%PTRFAC) 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 100 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 + 3 * 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 C Store size of receive buffers in module CALL CMUMPS_BUF_DIST_IRECV_SIZE( id%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 SPMD C PERLU_ON = .TRUE. CALL CMUMPS_MAX_MEM( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) id%INFO(16) = TOTAL_MBYTES IF ( PROK ) THEN WRITE(MP,'(A,I10) ') & ' ** Space in MBYTES used during factorization :', & id%INFO(16) END IF C C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in bytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in bytes for facto, C sum over all processors C ---------------------------------------------------- C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Memory relaxation parameter ( ICNTL(14) ) :', & KEEP(12) WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for facto :', & id%INFOG(18) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during facto :', & ( id%INFOG(19)-id%INFO(16) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during facto :', & id%INFOG(19) / id%NSLAVES END IF 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 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 CALL CMUMPS_FAC_B( id%N, NSTEPS,id%S(1),MAXS,id%IS(1),LIW, & 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, id%BUFR(1),id%LBUFR, & id%LBUFR_BYTES, 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) & ) IF ( PROK .and. KEEP(38) .ne. 0 ) THEN WRITE( MP, 175 ) KEEP(49) END IF 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 ---------------- DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) 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 C next line should be enough but ... C DEALLOCATE( id%DBLARR ) 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 send buffers C They will be reallocated C in the solve. C ------------------------ IF (associated(id%BUFR)) THEN DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) END IF CALL CMUMPS_BUF_DEALL_CB( IERR ) 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 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) IF ( PROKG ) THEN IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) TIME ELSE WRITE(MPG,185) TIME ENDIF ENDIF ENDIF CC Made available to users on release 4.4 (April 2005) PERLU_ON = .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), & PERLU_ON, TOTAL_BYTES) 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 IF (PROK ) THEN WRITE(MP,'(A,I10) ') & ' ** Effective minimum Space in MBYTES for facto :', & TOTAL_MBYTES ENDIF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K69 = id%KEEP8(69) ELSE K67 = 0_8 K68 = 0_8 K69 = 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 CALL CMUMPS_AVGMAX_STAT8(PROKG, MPG, K67, id%NSLAVES, & id%COMM, "effective space used in S (KEEP8(67)) =") C C ---------------------------------------------------- C Centralize memory statistics on the host C C INFOG(21) = size of mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & TOTAL_MBYTES, id%INFOG(21), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Rank of processor needing largest memory :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Space in MBYTES used by this processor :', & id%INFOG(21) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Avg. Space in MBYTES per working proc :', & ( id%INFOG(22)-TOTAL_MBYTES ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Avg. Space in MBYTES per working proc :', & id%INFOG(22) / id%NSLAVES END IF END IF * save statistics in KEEP array. KEEP(33) = id%INFO(11) ! this should be the other way round C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations 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(6), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(6), INFOG(9)) CALL MPI_REDUCE( id%INFO(10), INFOG(10), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) 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 ============================== C LOW-RANK C ============================== IF ( KEEP(486) .GT. 0 ) THEN !LR is activated CALL MPI_REDUCE( GLOBAL_BLR_SAVINGS, TMP_GLOBAL_BLR_SAVINGS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FR_MRY, TMP_ACC_FR_MRY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_LR_FLOP_GAIN, TMP_ACC_LR_FLOP_GAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_TRSM, TMP_ACC_FLOP_FR_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_TRSM, TMP_ACC_FLOP_LR_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_UPDT, TMP_ACC_FLOP_FR_UPDT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_UPDT, TMP_ACC_FLOP_LR_UPDT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_RMB, TMP_ACC_FLOP_RMB & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_UPDT_OUT, & TMP_ACC_FLOP_LR_UPDT_OUT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_DEC_ACC, TMP_ACC_FLOP_DEC_ACC & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_REC_ACC, TMP_ACC_FLOP_REC_ACC & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_TRSM, TMP_ACC_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_PANEL, TMP_ACC_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FRFRONTS, TMP_ACC_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_DEMOTE, TMP_ACC_FLOP_DEMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_CB_DEMOTE, TMP_ACC_FLOP_CB_DEMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_CB_PROMOTE,TMP_ACC_FLOP_CB_PROMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_FACTO,TMP_ACC_FLOP_FR_FACTO & , 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 ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN & + ACC_FLOP_DEMOTE + ACC_FLOP_FRFRONTS CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,AVG_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_ACC_FLOP_LR_FACTO = AVG_ACC_FLOP_LR_FACTO/id%NPROCS ENDIF CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,MIN_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,MAX_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( ACC_UPDT_TIME,TMP_ACC_UPDT_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_DEMOTING_TIME,TMP_ACC_DEMOTING_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_CB_DEMOTING_TIME, & TMP_ACC_CB_DEMOTING_TIME, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, MASTER, & id%COMM, IERR) CALL MPI_REDUCE( ACC_PROMOTING_TIME,TMP_ACC_PROMOTING_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FRPANELS_TIME,TMP_ACC_FRPANELS_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_I_TIME,TMP_ACC_FAC_I_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_MQ_TIME,TMP_ACC_FAC_MQ_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_SQ_TIME,TMP_ACC_FAC_SQ_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_TRSM_TIME,TMP_ACC_TRSM_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FRFRONTS_TIME,TMP_ACC_FRFRONTS_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_LR_MODULE_TIME,TMP_ACC_LR_MODULE_TIME & , 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 GLOBAL_BLR_SAVINGS = TMP_GLOBAL_BLR_SAVINGS ACC_FR_MRY = TMP_ACC_FR_MRY ACC_LR_FLOP_GAIN = TMP_ACC_LR_FLOP_GAIN ACC_FLOP_TRSM = TMP_ACC_FLOP_TRSM ACC_FLOP_PANEL = TMP_ACC_FLOP_PANEL ACC_FLOP_LR_TRSM = TMP_ACC_FLOP_LR_TRSM ACC_FLOP_FR_TRSM = TMP_ACC_FLOP_FR_TRSM ACC_FLOP_LR_UPDT = TMP_ACC_FLOP_LR_UPDT ACC_FLOP_LR_UPDT_OUT = TMP_ACC_FLOP_LR_UPDT_OUT ACC_FLOP_RMB = TMP_ACC_FLOP_RMB ACC_FLOP_DEC_ACC = TMP_ACC_FLOP_DEC_ACC ACC_FLOP_REC_ACC = TMP_ACC_FLOP_REC_ACC ACC_FLOP_FR_UPDT = TMP_ACC_FLOP_FR_UPDT ACC_FLOP_DEMOTE = TMP_ACC_FLOP_DEMOTE ACC_FLOP_CB_DEMOTE = TMP_ACC_FLOP_CB_DEMOTE ACC_FLOP_CB_PROMOTE = TMP_ACC_FLOP_CB_PROMOTE ACC_FLOP_FRFRONTS = TMP_ACC_FLOP_FRFRONTS CNT_NODES = TMP_CNT_NODES ACC_FLOP_FR_FACTO = TMP_ACC_FLOP_FR_FACTO C ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN C & + ACC_FLOP_DEMOTE ACC_UPDT_TIME = TMP_ACC_UPDT_TIME /id%NPROCS ACC_DEMOTING_TIME = TMP_ACC_DEMOTING_TIME /id%NPROCS ACC_CB_DEMOTING_TIME = TMP_ACC_CB_DEMOTING_TIME/id%NPROCS ACC_PROMOTING_TIME = TMP_ACC_PROMOTING_TIME /id%NPROCS ACC_FRPANELS_TIME = TMP_ACC_FRPANELS_TIME /id%NPROCS ACC_FAC_I_TIME = TMP_ACC_FAC_I_TIME /id%NPROCS ACC_FAC_MQ_TIME = TMP_ACC_FAC_MQ_TIME /id%NPROCS ACC_FAC_SQ_TIME = TMP_ACC_FAC_SQ_TIME /id%NPROCS ACC_TRSM_TIME = TMP_ACC_TRSM_TIME /id%NPROCS ACC_FRFRONTS_TIME = TMP_ACC_FRFRONTS_TIME /id%NPROCS ACC_LR_MODULE_TIME = TMP_ACC_LR_MODULE_TIME /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110),RINFOG(3),id%NPROCS, & PROKG, MPG) FRONTWISE = 0 IF (id%KEEP(486).EQ.1) THEN C BLR was activated 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, & 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), KEEP(485), KEEP(467), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) ELSE RINFOG(14) = 0.0E00 ENDIF 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 C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(16). C Note that KEEP(17) already has the same value on all procs INFOG(28)=KEEP(112)+KEEP(17) 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 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),id%KEEP8(6),INFOG(10), & 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(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency 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 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 #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 CALL CMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8, .TRUE.) C INFO(1): input only ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') CALL MUMPS_FDM_END('F') 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 530 is done when an error occurs before C the calls to 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 FOR MATRIX DISTRIBUTION =',F12.4) 166 FORMAT(' Convergence error after scaling 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/ & ' REAL SPACE FOR FACTORS =',I16/ & ' INTEGER SPACE FOR FACTORS =',I16/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I16) 172 FORMAT(/' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' NUMBER OF WORKING PROCESSES =',I16/ & ' OUT-OF-CORE OPTION (ICNTL(22)) =',I16/ & ' REAL SPACE FOR FACTORS =',I16/ & ' INTEGER SPACE FOR FACTORS =',I16/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I16/ & ' NUMBER OF NODES IN THE TREE =',I16/ & ' MEMORY ALLOWED (MB -- 0: N/A ) =',I16/ & ' RELATIVE THRESHOLD FOR PIVOTING, CNTL(1) =',D16.4) 173 FORMAT( ' PERFORM FORWARD DURING FACTO, NRHS =',I16) 175 FORMAT(/' NUMBER OF ENTRIES FOR // ROOT =',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) =',F12.4) 99979 FORMAT( ' RINFOG(12) DETERMINANT (imaginary part) =',F12.4) 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 NULL PIVOTS DETECTED BY ICNTL(16) =',I16) 99991 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(24) =',I16) 99992 FORMAT( ' INFOG(28) ESTIMATED DEFICIENCY =',I16) 99984 FORMAT(/' GLOBAL STATISTICS '/ & ' RINFOG(2) OPERATIONS IN NODE ASSEMBLY =',1PD10.3/ & ' ------(3) OPERATIONS IN NODE ELIMINATION=',1PD10.3/ & ' 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 SUBROUTINE CMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL PROKG INTEGER MPG INTEGER(8) VAL INTEGER NSLAVES INTEGER COMM CHARACTER*42 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 WRITE(MPG,100) " Maximum ", MSG, MAX_VAL WRITE(MPG,100) " Average ", MSG, int(AVG_VAL,8) ENDIF RETURN 100 FORMAT(A9,A42,I16) 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%NSLAVES) 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.1.2/src/fac_asm_build_sort_index_ELT_m.F0000664000175000017500000003753213164366241021670 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, & IW, LIW, & INTARR, LINTARR, ITLOC, & FILS, FRERE_STEPS, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, 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)), & NBPROCFILS(KEEP(28)), PERM(N) INTEGER, TARGET :: IW(LIW) INTEGER, INTENT(IN), TARGET :: IWPOSCB 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 #if ! defined(NO_XXNBPR) INTEGER INBPROCFILS_SON #endif INTEGER TYPESPLIT INTEGER ELTI, NUMELT_IBROT INCLUDE 'mumps_headers.h' INTEGER, POINTER :: SON_IWPOSCB INTEGER, POINTER, DIMENSION(:) :: SON_IW INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTTRI, PTLAST INTEGER MUMPS_TYPESPLIT, MUMPS_TYPENODE EXTERNAL MUMPS_TYPESPLIT, MUMPS_TYPENODE #if ! defined(NO_XXNBPR) IW(IOLDPS+XXNBPR) = 0 #endif Pos_First_NUMORG = 1 TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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)),SLAVEF) J= MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(IFSON)), & SLAVEF) 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 #if ! defined(NO_XXNBPR) IF (PIMASTER(STEP(IFSON)) .GT. IWPOSCB) THEN INBPROCFILS_SON = PIMASTER(STEP(IFSON))+XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(IFSON))+XXNBPR ENDIF #endif NBPROCFILS(STEP(IFSON)) = NSLSON NBPROCFILS(STEP(INODE)) = NSLSON #if ! defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=NSLSON IW(INBPROCFILS_SON) = NSLSON CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 IF (NUMSTK.GT.0) THEN ALLOCATE(PTTRI(NUMSTK), stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 GOTO 800 ENDIF ALLOCATE(PTLAST(NUMSTK), stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 GOTO 800 ENDIF 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 ! defined(NO_XXNBPR) IF (PIMASTER(STEP(ISON)).GT.IWPOSCB) THEN INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ENDIF #endif IF (NIV1) THEN NBPROCFILS(STEP(ISON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON #if ! defined(NO_XXNBPR) IW(INBPROCFILS_SON) = NSLSON IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + NSLSON CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)),IW(INBPROCFILS_SON)) #endif ELSE IF (LEVEL1_SON) THEN NBPROCFILS(STEP(ISON)) = 1 #if ! defined(NO_XXNBPR) IW(INBPROCFILS_SON) = 1 #endif ELSE NBPROCFILS(STEP(ISON)) = NSLSON #if ! defined(NO_XXNBPR) IW(INBPROCFILS_SON) = NSLSON #endif ENDIF NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(ISON)) #if ! defined(NO_XXNBPR) IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + IW(INBPROCFILS_SON) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .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(PTTRI)) DEALLOCATE(PTTRI) IF (allocated(PTLAST)) DEALLOCATE(PTLAST) RETURN END SUBROUTINE MUMPS_ELT_BUILD_SORT END MODULE MUMPS_BUILD_SORT_INDEX_ELT_M MUMPS_5.1.2/src/somp_tps_m.F0000664000175000017500000000070113164366263016012 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE SMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE SMUMPS_TPS_M_RETURN MUMPS_5.1.2/src/zfac_front_aux.F0000664000175000017500000020440713164366266016656 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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,IOLDPS,POSELT,UU,SEUIL,KEEP, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER KEEP(500) 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 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 NOFFW,NPIV,IPIV,IPIV_SHIFT 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 !$ INTEGER :: JJMAX !$ DOUBLE PRECISION :: RRMAX, VALABS !$ INTEGER :: NOMP, CHUNK, K360 !$ K360 = KEEP(360) !$ NOMP = OMP_GET_MAX_THREADS() NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) 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)).GT.max(UU*MAXFROMN,SEUIL, & tiny(MAXFROMN))) 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 IF (KEEP(351).EQ.1) THEN !$ IF (NOMP.GT.1 .AND. J3.GE.K360) THEN !$ JMAX = 1 !$ RMAX = RZERO !$ CHUNK = max(K360/2,J3/NOMP) !$OMP PARALLEL PRIVATE(JJ,VALABS,JJMAX,RRMAX) !$OMP& FIRSTPRIVATE(J1,NFRONT8,J3) !$ RRMAX = RZERO !$OMP DO schedule(static, CHUNK) !$ DO J = 1, J3 !$ JJ = J1 + int(J-1,8)*NFRONT8 !$ VALABS = abs(A(JJ)) !$ IF (VALABS.GT.RRMAX) THEN !$ RRMAX = VALABS !$ JJMAX = J !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (RRMAX.GT.0.0) THEN !$OMP CRITICAL !$ IF (RRMAX.GT.RMAX) THEN !$ RMAX = RRMAX !$ JMAX = JJMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE JMAX = ZMUMPS_IXAMAX(J3,A(J1),NFRONT) !$ ENDIF ELSE JMAX = ZMUMPS_IXAMAX(J3,A(J1),NFRONT) ENDIF 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) 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) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(J1) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) IF (J3.GE.K360) DO J=1,J3 J1 = J1_ini + int(J-1,8) * NFRONT8 RMAX = max(abs(A(J1)),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)).GT.max(UU*RMAX,SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE.max(UU*RMAX,SEUIL,tiny(RMAX))) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DKEEP(6), & KEEP(259) ) ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 KEEP(260)=-KEEP(260) 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 KEEP(260)=-KEEP(260) 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 (KEEP(201).EQ.1) 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) !$ 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 NEL,IROW,NEL2,JCOL, NCB INTEGER NPIVP1 COMPLEX(kind=8), PARAMETER :: ONE=(1.0D0,0.0D0) !$ LOGICAL:: OMP_FLAG !$ INTEGER:: NOMP, K360, CHUNK !$ NOMP = OMP_GET_MAX_THREADS() !$ K360 = KEEP(360) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NEL2 = NASS - NPIVP1 NCB = NFRONT - NASS - KEEP(253) IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) !$ OMP_FLAG = .FALSE. !$ CHUNK = NEL !$ 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) !$ ENDIF !$ ELSE !$ OMP_FLAG = .TRUE. !$ CHUNK = max(K360/2,NEL/NOMP) !$ 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) 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_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM & ) IMPLICIT NONE INTEGER(8) :: LA,POSELT COMPLEX(kind=8) A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL CALL_UTRSM INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1,NEL11 COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) CALL ztrsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_UTRSM) THEN UPOS = POSELT + int(NASS,8) CALL ztrsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) CALL zgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE ZMUMPS_FAC_P SUBROUTINE ZMUMPS_FAC_P_PANEL(A,LAFAC,NFRONT, & NPIV,NASS, IW, LIWFAC, & MonBloc, TYPEFile, MYID, KEEP8, & STRAT, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten) USE ZMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NPIV, NASS INTEGER(8) :: LAFAC INTEGER LIWFAC, TYPEFile, MYID, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten, STRAT COMPLEX(kind=8) A(LAFAC) INTEGER IW(LIWFAC) INTEGER(8) KEEP8(150) TYPE(IO_BLOCK) :: MonBloc INTEGER(8) :: LPOS2,LPOS1,LPOS INTEGER NEL1,NEL11 COMPLEX(kind=8) ALPHA, ONE LOGICAL LAST_CALL PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = 1_8 + int(NASS,8) * int(NFRONT,8) CALL ztrsm('L','L','N','N',NPIV,NEL1,ONE,A(1),NFRONT, & A(LPOS2),NFRONT) LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) LPOS = LPOS2 + int(NPIV,8) LPOS1 = int(1 + NPIV,8) CALL zgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE ZMUMPS_FAC_P_PANEL 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, & CALL_UTRSM, CALL_GEMM, WITH_COMM_THREAD ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD INTEGER(8) :: NFRONT8 INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER NELIM, LKJIW, NEL1, NEL11 COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 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 IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + & int(IEND_BLOCK,8) POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*NFRONT8 + int(IBEG_BLOCK - 1,8) CALL ztrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) IF (CALL_UTRSM) THEN CALL ztrsm('R','U','N','U',NEL1,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),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 ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_SQ SUBROUTINE ZMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB) 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) 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, LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG) USE ZMUMPS_OOC IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW, & 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) TYPE(IO_BLOCK), intent(inout) :: MonBloc INTEGER :: NPIV, NEL1, STRAT, TYPEFile, IFLAG_OOC, & 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 (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_BOTH_LU MonBloc%LastPiv= NPIV CALL ZMUMPS_FAC_P_PANEL(A(POSELT), LAFAC, NFRONT, & NPIV, NASS, IW(IOLDPS), LIWFAC, & MonBloc, TYPEFile, MYID, KEEP8, & STRAT, IFLAG_OOC, & LNextPiv2beWritten, UNextPiv2beWritten) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC ELSE CALL ZMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM & ) ENDIF 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,IOLDPS,POSELT,UU,SEUIL, & KEEP, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv & ) IF (INOPV.NE.1) THEN CALL ZMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL) 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,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, & 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 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 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 DOUBLE PRECISION PIVNUL COMPLEX(kind=8) FIXA, CSEUIL INTEGER NPIV,IPIV INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF INTEGER ZMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0D0/ !$ INTEGER :: J4,JJMAX,NOMP,CHUNK,K361 !$ DOUBLE PRECISION :: RRMAX,VALABS INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U !$ NOMP = OMP_GET_MAX_THREADS() !$ K361 = KEEP(361) 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 IF (KEEP(201).EQ.1) 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 IF(abs(A(APOS)).LT.SEUIL) THEN IF (dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF KEEP(98) = KEEP(98)+1 ELSE IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1) 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.GT.0.AND.UU.GT.RZERO) GO TO 340 IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 340 CONTINUE 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 IF (KEEP(351).EQ.1) THEN !$ IF (NOMP.GT.1 .AND. J.GE.K361) THEN !$ JMAX = 1 !$ RMAX = RZERO !$ CHUNK = max(K361/2,J/NOMP) !$OMP PARALLEL PRIVATE(J3,VALABS,JJMAX,RRMAX) !$OMP& FIRSTPRIVATE(J1,J) !$ RRMAX = RZERO !$OMP DO schedule(static, CHUNK) !$ DO J4 = 1, J !$ J3 = J1 + int(J4-1,8) !$ VALABS = abs(A(J3)) !$ IF(VALABS.GT.RRMAX) THEN !$ RRMAX = VALABS !$ JJMAX = J4 !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (RRMAX.GT.0.0) THEN !$OMP CRITICAL !$ IF (RRMAX.GT.RMAX) THEN !$ RMAX = RRMAX !$ JMAX = JJMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE JMAX = ZMUMPS_IXAMAX(J,A(J1),1) !$ ENDIF ELSE JMAX = ZMUMPS_IXAMAX(J,A(J1),1) ENDIF 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),8) ELSE J2 = APOS +int(- NPIV + NASS - 1 - KEEP(253),8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1) THEN !$ CHUNK = max(K361/2,int(J2-J1)/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 ENDIF 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF ( RMAX .LE. PIVNUL ) THEN 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(LAST_ROW-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LAST_ROW-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO KEEP(109) = KEEP(109)+1 ISW = IOLDPS+HF+ & IW(IOLDPS+1+XSIZE)+IPIV-NPIVP1 PIVNUL_LIST(KEEP(109)) = IW(ISW) 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 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 IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DKEEP(6), & KEEP(259)) ENDIF 385 CONTINUE IF (IPIV.EQ.NPIVP1) GO TO 400 KEEP(260)=-KEEP(260) 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 KEEP(260)=-KEEP(260) 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 (KEEP(201).EQ.1) 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, & NNEG, & 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,INODE,IFLAG,INOPV, & IOLDPS, NNEG INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv 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 include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM DOUBLE PRECISION RMAX,AMAX,TMAX DOUBLE PRECISION MAXPIV DOUBLE PRECISION PIVNUL COMPLEX(kind=8) FIXA, CSEUIL COMPLEX(kind=8) PIVOT,DETPIV INCLUDE 'mumps_headers.h' 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) LOGICAL OMP_FLAG INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L 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) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF KEEP(98) = KEEP(98)+1 ELSE IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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 IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(A(APOS), DKEEP(6), KEEP(259)) 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 (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. 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 + 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 IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSEIF (PIVOT_OPTION.EQ.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT: PIVOT_OPTION=', & PIVOT_OPTION ENDIF J1_ini = J1 IF ( (LIM - KEEP(253) - IEND_BLOCK).GE.300 ) THEN OMP_FLAG = .TRUE. ELSE OMP_FLAG = .FALSE. ENDIF !$OMP PARALLEL DO PRIVATE(J1) REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - KEEP(253) - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN KEEP(109) = KEEP(109)+1 PIVNUL_LIST(KEEP(109)) = -1 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,NFRONT - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) 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,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSEIF (PIVOT_OPTION.EQ.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT: PIVOT_OPTION=', & PIVOT_OPTION 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 (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 OMP_FLAG = (LIM-JMAX-KEEP(253). GE. 300) !$OMP PARALLEL DO IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX - KEEP(253) 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_FLAG = (LIM-JMAX-KEEP(253). GE. 300) !$OMP PARALLEL DO PRIVATE(JJ) REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX-KEEP(253) 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 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 IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(103) = KEEP(103)+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 CALL ZMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDA, NFRONT, 1, KEEP(219), KEEP(50), & KEEP(IXSZ), -9999) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) 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, & KEEP253, PIVOT_OPTION, IEND_BLR & ) 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) :: PIVOT_OPTION, 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) :: KEEP253 COMPLEX(kind=8) VALPIV DOUBLE PRECISION :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2, NEL, LIM 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 COMPLEX(kind=8) SWOP,DETPIV,MULT1,MULT2 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 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 MAXFROMM = 0.0D00 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 IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSE LIM = IEND_BLR ENDIF NCB1 = LIM - IEND_BLOCK 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 - KEEP253 > 300) DO I=NEL2+1, NEL2 + NCB1 - KEEP253 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 - KEEP253 + 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 ELSE IF (PIVOT_OPTION.EQ.3) THEN LIM = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LIM = NASS ELSE LIM = IEND_BLR ENDIF 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(LIM-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL zcopy(LIM-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 DO J2 = IEND_BLOCK+1,LIM 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 JJ = JJ + NFRONT8 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_MQ_LDLT SUBROUTINE ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,LAST_VAR,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & PIVOT_OPTION, CALL_TRSM) 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, intent(in) :: LAST_VAR INTEGER :: KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: PIVOT_OPTION LOGICAL, intent(in) :: CALL_TRSM INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1, I, II INTEGER(8) :: LPOS,UPOS,APOS INTEGER IROW INTEGER Block INTEGER BLSIZE, ELSIZE COMPLEX(kind=8) ONE, ALPHA, VALPIV INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) LDA8 = int(LDA,8) ELSIZE = IEND_BLOCK - IBEG_BLOCK +1 NEL1 = LAST_VAR - IEND_BLOCK NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (PIVOT_OPTION.LE.1.AND.CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) CALL ztrsm('L', 'U', 'T', 'U', ELSIZE, NEL1, ONE, & A(APOS), LDA, A(LPOS), LDA) !$OMP PARALLEL PRIVATE(VALPIV,I,II) DO I = 1, ELSIZE VALPIV = ONE/A(POSELT+(LDA8+1_8)*int(IBEG_BLOCK+I-2,8)) !$OMP DO DO II = 1,NEL1 A(UPOS+int(I-1,8)*LDA8 + int(II-1,8)) = & A(LPOS+int(I-1,8) + int(II-1,8)*LDA8) A(LPOS+int(I-1,8) + int(II-1,8)*LDA8) = & A(LPOS+int(I-1,8) + int(II-1,8)*LDA8)*VALPIV ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ENDIF IF ( LAST_VAR - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_VAR - IEND_BLOCK END IF IF ( NASS - IEND_BLOCK .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = IEND_BLOCK+1, LAST_VAR, BLSIZE Block = min( BLSIZE, NASS - 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_VAR, BLSIZE Block = min( BLSIZE, LAST_VAR - 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_VAR - IROW + 1, NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF LPOS = POSELT + int(LAST_VAR,8)*LDA8 + int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_VAR,8)*LDA8 + int(IEND_BLOCK,8) IF (PIVOT_OPTION.EQ.3) THEN CALL zgemm('N', 'N', NEL1, NFRONT-LAST_VAR, NPIV_BLOCK, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) ELSEIF (PIVOT_OPTION.EQ.2.AND.(NASS.GT. LAST_VAR)) THEN CALL zgemm('N', 'N', NEL1, NASS-LAST_VAR, NPIV_BLOCK, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_SQ_LDLT SUBROUTINE ZMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, NASS, & LDA, NFRONT, LEVEL, K219, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, NASS, LEVEL, K219, K50, XSIZE COMPLEX(kind=8) A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: LASTROW2SWAP, 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 IF (LEVEL .EQ. 1) THEN LASTROW2SWAP = NFRONT ELSE LASTROW2SWAP = NASS ENDIF CALL zswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF (K219.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2) 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_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) 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 INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, I, J, IROWEND INTEGER I2, I2END, Block2 COMPLEX(kind=8) ONE, ALPHA, BETA, ZERO COMPLEX(kind=8) :: MULT1, MULT2, A11, DETPIV, A22, A12 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(57) ) THEN BLSIZE = KEEP(58) 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 CALL ztrsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NPIV, ONE, & A( POSELT ), LDA, & A( POSELT + LDA8 * int(NPIV,8) ), LDA ) 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 DPOS = POSELT I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN A11 = ONE/A(DPOS) CALL zcopy(Block, A(LPOS+int(I-1,8)), LDA, & A(UPOS+int(I-1,8)*LDA8), 1) CALL zscal(Block, A11, A(LPOS+int(I-1,8)), LDA) DPOS = DPOS + int(LDA+1,8) I = I+1 ELSE CALL zcopy(Block, A(LPOS+int(I-1,8)), LDA, & A(UPOS+int(I-1,8)*LDA8), 1) CALL zcopy(Block, A(LPOS+int(I,8)), LDA, & A(UPOS+int(I,8)*LDA8), 1) 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,Block 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 DPOS = POSPV2 + int(LDA+1,8) I = I+2 ENDIF ENDDO 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 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 END MODULE ZMUMPS_FAC_FRONT_AUX_M MUMPS_5.1.2/src/cfac_asm.F0000664000175000017500000005664613164366264015412 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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(8) :: POSELT 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)) POSELT = PTRAST(STEP(INODE)) 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, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), & RHS_MUMPS) 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) IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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 INCLUDE 'mumps_headers.h' INTRINSIC real IOLDPS = PTRIST(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) 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(APOS+int(J-1,8)) = A( 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(K8) = A(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(APOS:APOS+int(NBCOLS-IDIAG-1,8))= & A(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(K8) = A(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 & ) 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 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.300 !$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)) & A(JJ2) = cmplx(VALSON(JJ1),kind=kind(A)) 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) 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) 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 :: 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)) A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = ZERO NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) 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 MUMPS_5.1.2/src/sfac_process_blfac_slave.F0000664000175000017500000004055613164366263020641 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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 IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS(KEEP(28)), 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 ) 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 IOLDPS, LCONT1, NROW1, NCOL1, NPIV1, NASS1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok LOGICAL SEND_LR INTEGER SEND_LR_INT 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 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, NB_BLR_COL, NPARTSASS_MASTER INTEGER :: MAXI_CLUSTER_TMP, MAXI_CLUSTER REAL, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT REAL, ALLOCATABLE, DIMENSION(:,:):: BLOCKLR INTEGER :: LWORK REAL,ALLOCATABLE,DIMENSION(:) :: RWORK 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, & SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF IF (SEND_LR) 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))) ALLOCATE(BEGS_BLR_U(NB_BLR_U+2)) CALL SMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, KEEP(470), & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) IF ( LRLU .LT. LAELL ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLUS, IERROR) GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress SMUMPS_PROCESS_BLFAC_SLAVE' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLU, IERROR) GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL KEEP8(69) = min(KEEP8(71), KEEP8(69)) 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 (SEND_LR) THEN DYNAMIC = .FALSE. ENDIF IF (DYNAMIC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN write(*,*) MYID, ' : PB allocation U in blfac_slave ' & , LAELL 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(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) ) #if defined(IBC_TEST) MSGSOU = IW( PTRIST(STEP(INODE)) + 9 + KEEP(IXSZ) ) #else MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 )) POSELT = PTRAST(STEP( INODE )) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NASS1 = IW( IOLDPS + 1 + 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 (SEND_LR) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_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 ( & A, LA, POSELT, IFLAG, IERROR, NCOL1, & BEGS_BLR_LS, BEGS_BLR_U, & CURRENT_BLR_U, & BLR_LS, NB_BLR_LS+1, & BLR_U, NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, KEEP(470), & KEEP(481), DKEEP(8), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR_U, KEEP8, .FALSE.) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) CALL SMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8, .TRUE.) 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( LPOS ), NCOL1, ONE, & A( CPOS ), NCOL1 ) ELSE CALL sgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A( LPOS ), NCOL1, ONE, & A( 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.SEND_LR) THEN IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + 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)), SLAVEF ) 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 IF (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN IOLDPS = PTRIST(STEP( INODE )) CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) NB_BLR_LS = size(BEGS_BLR_LS) - 2 CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 CALL MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_TMP) MAXI_CLUSTER = MAXI_CLUSTER_TMP CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_TMP) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_TMP) LWORK = MAXI_CLUSTER*MAXI_CLUSTER ALLOCATE(RWORK(2*MAXI_CLUSTER),WORK(LWORK),TAU(MAXI_CLUSTER), & JPVT(MAXI_CLUSTER), BLOCKLR(MAXI_CLUSTER,MAXI_CLUSTER), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4) write(6,*) 'ERROR 1 allocate temporary BLR blocks during', & ' SMUMPS_PROCESS_BLFAC_SLAVE ', IERROR GOTO 700 ENDIF CALL SMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_LS, NB_BLR_LS+1, & BEGS_BLR_COL, NB_BLR_COL, NPARTSASS_MASTER, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., 0, KEEP(484)) DEALLOCATE(RWORK,WORK,TAU,JPVT,BLOCKLR) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.1.2/src/ana_AMDMF.F0000664000175000017500000005435013164366241015302 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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), ELEN(N), LAST(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 :: 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 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 WRITE(6,*) ' WARNING MUMPS_SYMQAMD_NEW on Options ' 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 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 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 .AND. DEXT .EQ. 0) THEN IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (AGG6 .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 .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.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.1.2/src/zfac_driver.F0000664000175000017500000037056013164366266016150 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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_CORE USE ZMUMPS_LR_STATS USE ZMUMPS_LR_DATA_M, only: ZMUMPS_BLR_INIT_MODULE, & ZMUMPS_BLR_END_MODULE 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 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 C Explicit interface needed because C of "id" derived datatype argument 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 C 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(8) ::KEEP826_SAVE INTEGER(8) K67 INTEGER(8) K68,K69 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF INTEGER ZMUMPS_LBUF, ZMUMPS_LBUFR_BYTES, ZMUMPS_LBUF_INT INTEGER(8) ZMUMPS_LBUFR_BYTES8, ZMUMPS_LBUF8 INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, NSTEPS, K28, LPOOL, LIW 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 INTEGER MIN_PERLU, MAXIS_ESTIM INTEGER MAXIS INTEGER(8) :: MAXS 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 INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER LIWK, LWK_REAL INTEGER(8) :: LWK C SLAVE: used to determine if proc has the role of a slave LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED C WK_USER_PROVIDED is set to true when workspace WK_USER is provided by user DOUBLE PRECISION :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2 DOUBLE PRECISION :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER FRONTWISE C temporary variable for collecting stats from all processors DOUBLE PRECISION :: TMP_GLOBAL_BLR_SAVINGS DOUBLE PRECISION :: TMP_ACC_FR_MRY DOUBLE PRECISION :: TMP_ACC_LR_FLOP_GAIN DOUBLE PRECISION :: TMP_ACC_FLOP_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_PANEL DOUBLE PRECISION :: TMP_ACC_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_ACC_FLOP_LR_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_FR_TRSM DOUBLE PRECISION :: TMP_ACC_FLOP_LR_UPDT DOUBLE PRECISION :: TMP_ACC_FLOP_LR_UPDT_OUT DOUBLE PRECISION :: TMP_ACC_FLOP_RMB DOUBLE PRECISION :: TMP_ACC_FLOP_DEC_ACC DOUBLE PRECISION :: TMP_ACC_FLOP_REC_ACC DOUBLE PRECISION :: TMP_ACC_FLOP_FR_UPDT DOUBLE PRECISION :: TMP_ACC_FLOP_DEMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_CB_DEMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_CB_PROMOTE DOUBLE PRECISION :: TMP_ACC_FLOP_FR_FACTO INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_ACC_UPDT_TIME DOUBLE PRECISION :: TMP_ACC_DEMOTING_TIME DOUBLE PRECISION :: TMP_ACC_CB_DEMOTING_TIME DOUBLE PRECISION :: TMP_ACC_PROMOTING_TIME DOUBLE PRECISION :: TMP_ACC_FRPANELS_TIME DOUBLE PRECISION :: TMP_ACC_FAC_I_TIME DOUBLE PRECISION :: TMP_ACC_FAC_MQ_TIME DOUBLE PRECISION :: TMP_ACC_FAC_SQ_TIME DOUBLE PRECISION :: TMP_ACC_TRSM_TIME DOUBLE PRECISION :: TMP_ACC_FRFRONTS_TIME DOUBLE PRECISION :: TMP_ACC_LR_MODULE_TIME 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 C C External references C =================== INTEGER numroc EXTERNAL numroc C Fwd in facto: COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_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 C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS 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 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 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 ) IF ( PROKG .and. KEEP(53).GT.0 ) THEN WRITE(MPG,'(/A,I3)') ' Null space option :', KEEP(19) IF ( KEEP(21) .ne. N ) THEN WRITE( MPG, '(A,I10)') ' Max deficiency : ', KEEP(21) END IF IF ( KEEP(22) .ne. 0 ) THEN WRITE( MPG, '(A,I10)') ' Min deficiency : ', KEEP(22) END IF END IF 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 !Later: .GT. to allow ICNTL(22)=-1 # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF IF (id%MYID .EQ. MASTER) THEN IF (id%KEEP(480).NE.0) THEN id%KEEP(480) = 0 IF (PROK) & write(MP,'(A)') & ' MUMPS is not compiled with -DBLR_LUA ', & ' => Resetting KEEP(480) to 0' ENDIF IF (id%KEEP(475).NE.0) THEN id%KEEP(475) = 0 IF (PROK) & write(MP,'(A)') & ' MUMPS is not compiled with -DLRTRSM ', & ' => Resetting KEEP(475) to 0' 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 ) IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & " Internal ERROR with BLR setting " WRITE(MPG,'(A)') " BLR was not activated during ", & " analysis and is requested during factorization. " id%INFO(1)=-900 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(470), 23, MPI_INTEGER, & MASTER, id%COMM, IERR ) 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 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 C 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 C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL(1) = 0.0 C --------------------------------------- IF ( KEEP(50) .eq. 1 ) THEN IF (id%CNTL(1) .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') &' ** Warning : SPD solver called, resetting CNTL(1) to 0.0D0' END IF END IF id%CNTL(1) = ZERO END IF 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 (PROKG) WRITE(MPG,'(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 (PROKG) WRITE(MPG,'(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 (PROKG) WRITE(MPG,'(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 IF ( PROKG ) THEN WRITE( MPG, 172 ) id%NSLAVES, id%ICNTL(22), & id%KEEP8(111), KEEP(126), KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, id%CNTL(1) IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) 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 530 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL)) 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 530 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) 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 530 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,*) 'ERREUR 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)) RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 530 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 -Rank revealing on the Schur (ICNTL(16)/KEEP(19)) C CNTL(6) is used to set SEUIL and SEUIL_LDLT_NIV2 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. C Note that SEUIL* might be reset later in this routine C but only when static pivoting is on C which will be excluded if null pivots or C rank-revealing (RR) is on C ----------------------------------------------- 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) CNTL1 = id%CNTL(1) CALL MPI_BCAST(CNTL1, 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) 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 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).EQ.0) THEN C -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO ELSE C -- RR is on C July 2012 C CNTL(3) is the threshold used in the following C to compute the SEUIL used for postponing pivots to root C SEUIL*CNTL(6) is then the treshold for null pivot detection C (with 0< CNTL(6) <= 1) IF (CNTL3 .LT. ZERO) THEN SEUIL = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN SEUIL = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN SEUIL = N*EPS*ANORMINF ! standard articles ENDIF IF (PROKG) WRITE(MPG,*) & ' ABSOLUTE PIVOT THRESHOLD for rank revealing =',SEUIL ENDIF C After QR with pivoting of root or SVD, diagonal entries C need be analysed to determine null space vectors. C Two strategies are provided : id%DKEEP(9) = SEUIL IF (id%DKEEP(10).LT.MONE) THEN id%DKEEP(10)=MONE ELSEIF((id%DKEEP(10).LE.ONE).AND.(id%DKEEP(10).GE.ZERO)) THEN id%DKEEP(10)=1000.0D0 ENDIF SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN 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 IF (ANORMINF.EQ.ZERO) & CALL ZMUMPS_ANORMINF( id , ANORMINF, LSCAL ) IF (KEEP(19).NE.0) THEN C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed. C Pivot rows smaller than DKEEP(1) are directly added to null space C and thus considered as null pivot rows. Thus we define id%DKEEP(1) C relatively to SEUIL (which is based on CNTL(3)) IF (CNTL(6).GT.0.AND.CNTL(6).LT.1) THEN C we want DKEEP(1) < SEUIL id%DKEEP(1) = SEUIL*CNTL(6) ELSE id%DKEEP(1) = SEUIL* 0.01D0 ENDIF ELSE 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 id%DKEEP(1) = 1.0D-5*EPS*ANORMINF ENDIF ENDIF IF (PROKG) WRITE(MPG,*) & ' ZERO PIVOT DETECTION ON, THRESHOLD =',id%DKEEP(1) IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,*) & ' 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 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%NSLAVES) 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 C and in case of rank revealing 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 530 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 C -- Set KEEP(97) and compute static pivoting threshold. 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 ) C WRITE(*,*) id%MYID,': ANORMINF',ANORMINF ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE C WRITE(*,*) 'id%CNTL(4)',id%CNTL(4) 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 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 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C Allocate S on all nodes C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN C In-core MAXS_BASE8=id%KEEP8(12) ELSE C OOC or no factors stored MAXS_BASE8=id%KEEP8(14) ENDIF IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ELSE IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) C If PERLU < 0, we may obtain a C null or negative value of MAXS. IF (MAXS_BASE_RELAXED8 > huge(MAXS)) THEN C id%INFO(1)=-37 C id%INFO(2)=int(MAXS_BASE_RELAXED8/1000000_8) WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ENDIF MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) MAXS = MAXS_BASE_RELAXED8 C Note that in OOC this value of MAXS will be C overwritten if KEEP(96) .NE. 0 or if C ICNTL(23) (that is, KEEP8(4)) is provided. ELSE MAXS = 1_8 MAXS_BASE_RELAXED8 = 1_8 END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF C C If KEEP(96) is provided, C use it without asking questions C IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C C IF (KEEP(96).GT.0) THEN C -- useful mostly for internal testing: C -- we can force in this way a given value C -- of MAXS and forget about other input values C -- such as ICNTL(23) (KEEP8(4)/1D6) C -- that could change MAXS value. MAXS=int(KEEP(96),8) ELSE IF (id%KEEP8(4) .NE. 0_8) THEN C ------------------------- C WE TRY TO USE MEM_ALLOWED (KEEP8(4)/1D6) C ------------------------- C First compute what we have: TOTAL_MBYTES(PERLU) C and TOTAL_BYTES(PERLU) C PERLU_ON = .TRUE. CALL ZMUMPS_MAX_MEM( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, & id%KEEP8(28), id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., KEEP(201), & PERLU_ON, TOTAL_BYTES) C C Assuming that TOTAL_BYTES is due to MAXS rather than C to the temporary buffers used for the distribution of C the matrix on the slaves (arrowheads or element distrib), C then we have: C C KEEP8(4)-TOTAL_BYTES is the extra free space C C A simple algorithm to redistribute the extra space: C All extra freedom (it could be negative !) is added to MAXS: MAXS_BASE_RELAXED8=MAXS_BASE_RELAXED8 + & (id%KEEP8(4)-TOTAL_BYTES)/int(KEEP(35),8) IF (MAXS_BASE_RELAXED8 > int(huge(MAXS),8)) THEN WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ELSE IF (MAXS_BASE_RELAXED8 .LE. 0_8) THEN C We need more space in order to at least enough id%INFO(1)=-9 IF ( -MAXS_BASE_RELAXED8 .GT. & int(huge(id%INFO(1)),8) ) THEN WRITE(*,*) "I8: OVERFLOW" CALL MUMPS_ABORT() ENDIF id%INFO(2)=-int(MAXS_BASE_RELAXED8) ELSE MAXS=MAXS_BASE_RELAXED8 ENDIF ENDIF ENDIF ENDIF ! I_AM_SLAVE CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF CALL ZMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & id%COMM, "effective relaxed size of S =") C Next PROPINFO is there for possible negative C values of MAXS resulting from small MEM_ALLOWED CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN C We jump after the call to LOAD_END and OOC_END since we didn't C called yet OOC_INIT and LOAD_INIT GOTO 530 ENDIF IF ( I_AM_SLAVE ) THEN C ------------------ C Dynamic scheduling C ------------------ CALL ZMUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), KEEP(66), 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)-TOTAL_BYTES 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 #if ! defined(OLD_LOAD_MECHANISM) 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)) #endif IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 ! reset space allocated to zero ENDIF #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN 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 ELSE id%S => id%WK_USER(1:id%KEEP8(24)) 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 CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) CALL MUMPS_FDM_INIT('F',NB_ACTIVE_FRONTS_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_ACTIVE_FRONTS_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 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 C ---------------------------------------- IF (KEEP(38).NE.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 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) IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF 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 ) ) 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, id%I_AM_CAND, & id%CANDIDATES) C 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 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 ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) 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), id%S(1), MAXS, & 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, & & id%S(1), MAXS, & 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, & id%S(1), MAXS, 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), & id%S(1), MAXS, 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) TIME 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 slaves 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 integers, since byte is not C a standard datatype. C We now use KEEP(43) and KEEP(44) as estimated at analysis C to allocate appropriate buffer sizes. C C Reception buffer C ---------------- ZMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP( 35 ), 8) C ------------------- C Ensure a reasonable C 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 PERLU = KEEP( 12 ) C For hybrid scheduling (strategy 5), Abdou C wants a minimal amount of freedom even for C small/negative PERLU values. 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(43))-100,8)) ZMUMPS_LBUFR_BYTES = int( ZMUMPS_LBUFR_BYTES8 ) IF (KEEP(48)==5) THEN C Since the buffer is 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 ----------- ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(43)) * dble(KEEP(35)), 8 ) 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%NSLAVES ) 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 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 the 2 send buffers 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 CALL ZMUMPS_BUF_ALLOC_CB( ZMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= ZMUMPS_LBUF id%INFO(2)= (ZMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error in ZMUMPS_BUF_ALLOC_CB' & ,id%INFO(2) ENDIF GO TO 110 END IF C ----------------------------- C Allocate reception buffer and C keep it in the structure C ----------------------------- id%LBUFR_BYTES = ZMUMPS_LBUFR_BYTES id%LBUFR = (ZMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) IF (associated(id%BUFR)) DEALLOCATE(id%BUFR) ALLOCATE( id%BUFR( id%LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%LBUFR NULLIFY(id%BUFR) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%BFUR(', id%LBUFR,')', IERR ENDIF GO TO 110 END IF C C The buffers are declared INTEGER, because BYTE is not a C standard data type. The sizes are in bytes, so we allocate C a number of INTEGERs. The allocated size in integer is the C size in bytes divided by KEEP(34) C ------------------------------- C Allocate IS. IS will contain C factors and contribution blocks C ------------------------------- C Relax workspace at facto now C PERLU might have been modified reload initial value 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 + 2 * max(PERLU,10) * & ( MAXIS_ESTIM / 100 + 1 ) & ) IF (associated(id%IS)) DEALLOCATE( id%IS ) ALLOCATE( id%IS( MAXIS ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=MAXIS NULLIFY(id%IS) IF (LPOK) THEN WRITE(*,*) id%MYID,': Allocation error for id%IS(',MAXIS,')' ENDIF GO TO 110 END IF LIW = MAXIS C ----------------------- C Allocate PTLUST_S. PTLUST_S C is used by solve later C ----------------------- IF (associated( id%PTLUST_S )) DEALLOCATE(id%PTLUST_S) 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 100 END IF IF (associated( id%PTRFAC )) DEALLOCATE(id%PTRFAC) 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 100 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 + 3 * 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 C Store size of receive buffers in module CALL ZMUMPS_BUF_DIST_IRECV_SIZE( id%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 SPMD C PERLU_ON = .TRUE. CALL ZMUMPS_MAX_MEM( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) id%INFO(16) = TOTAL_MBYTES IF ( PROK ) THEN WRITE(MP,'(A,I10) ') & ' ** Space in MBYTES used during factorization :', & id%INFO(16) END IF C C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in bytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in bytes for facto, C sum over all processors C ---------------------------------------------------- C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Memory relaxation parameter ( ICNTL(14) ) :', & KEEP(12) WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for facto :', & id%INFOG(18) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during facto :', & ( id%INFOG(19)-id%INFO(16) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during facto :', & id%INFOG(19) / id%NSLAVES END IF 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 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 CALL ZMUMPS_FAC_B( id%N, NSTEPS,id%S(1),MAXS,id%IS(1),LIW, & 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, id%BUFR(1),id%LBUFR, & id%LBUFR_BYTES, 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) & ) IF ( PROK .and. KEEP(38) .ne. 0 ) THEN WRITE( MP, 175 ) KEEP(49) END IF 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 ---------------- DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) 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 C next line should be enough but ... C DEALLOCATE( id%DBLARR ) 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 send buffers C They will be reallocated C in the solve. C ------------------------ IF (associated(id%BUFR)) THEN DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) END IF CALL ZMUMPS_BUF_DEALL_CB( IERR ) 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 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 IF ( PROKG ) THEN IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) TIME ELSE WRITE(MPG,185) TIME ENDIF ENDIF ENDIF CC Made available to users on release 4.4 (April 2005) PERLU_ON = .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), & PERLU_ON, TOTAL_BYTES) 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 IF (PROK ) THEN WRITE(MP,'(A,I10) ') & ' ** Effective minimum Space in MBYTES for facto :', & TOTAL_MBYTES ENDIF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K69 = id%KEEP8(69) ELSE K67 = 0_8 K68 = 0_8 K69 = 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 CALL ZMUMPS_AVGMAX_STAT8(PROKG, MPG, K67, id%NSLAVES, & id%COMM, "effective space used in S (KEEP8(67)) =") C C ---------------------------------------------------- C Centralize memory statistics on the host C C INFOG(21) = size of mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & TOTAL_MBYTES, id%INFOG(21), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Rank of processor needing largest memory :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Space in MBYTES used by this processor :', & id%INFOG(21) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Avg. Space in MBYTES per working proc :', & ( id%INFOG(22)-TOTAL_MBYTES ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** EFF Min: Avg. Space in MBYTES per working proc :', & id%INFOG(22) / id%NSLAVES END IF END IF * save statistics in KEEP array. KEEP(33) = id%INFO(11) ! this should be the other way round C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations 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(6), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(6), INFOG(9)) CALL MPI_REDUCE( id%INFO(10), INFOG(10), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) 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 ============================== C LOW-RANK C ============================== IF ( KEEP(486) .GT. 0 ) THEN !LR is activated CALL MPI_REDUCE( GLOBAL_BLR_SAVINGS, TMP_GLOBAL_BLR_SAVINGS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FR_MRY, TMP_ACC_FR_MRY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_LR_FLOP_GAIN, TMP_ACC_LR_FLOP_GAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_TRSM, TMP_ACC_FLOP_FR_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_TRSM, TMP_ACC_FLOP_LR_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_UPDT, TMP_ACC_FLOP_FR_UPDT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_UPDT, TMP_ACC_FLOP_LR_UPDT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_RMB, TMP_ACC_FLOP_RMB & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_UPDT_OUT, & TMP_ACC_FLOP_LR_UPDT_OUT & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_DEC_ACC, TMP_ACC_FLOP_DEC_ACC & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_REC_ACC, TMP_ACC_FLOP_REC_ACC & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_TRSM, TMP_ACC_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_PANEL, TMP_ACC_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FRFRONTS, TMP_ACC_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_DEMOTE, TMP_ACC_FLOP_DEMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_CB_DEMOTE, TMP_ACC_FLOP_CB_DEMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_CB_PROMOTE,TMP_ACC_FLOP_CB_PROMOTE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_FR_FACTO,TMP_ACC_FLOP_FR_FACTO & , 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 ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN & + ACC_FLOP_DEMOTE + ACC_FLOP_FRFRONTS CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,AVG_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_ACC_FLOP_LR_FACTO = AVG_ACC_FLOP_LR_FACTO/id%NPROCS ENDIF CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,MIN_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FLOP_LR_FACTO,MAX_ACC_FLOP_LR_FACTO & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( ACC_UPDT_TIME,TMP_ACC_UPDT_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_DEMOTING_TIME,TMP_ACC_DEMOTING_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_CB_DEMOTING_TIME, & TMP_ACC_CB_DEMOTING_TIME, 1, & MPI_DOUBLE_PRECISION, MPI_SUM, MASTER, & id%COMM, IERR) CALL MPI_REDUCE( ACC_PROMOTING_TIME,TMP_ACC_PROMOTING_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FRPANELS_TIME,TMP_ACC_FRPANELS_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_I_TIME,TMP_ACC_FAC_I_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_MQ_TIME,TMP_ACC_FAC_MQ_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FAC_SQ_TIME,TMP_ACC_FAC_SQ_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_TRSM_TIME,TMP_ACC_TRSM_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_FRFRONTS_TIME,TMP_ACC_FRFRONTS_TIME & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( ACC_LR_MODULE_TIME,TMP_ACC_LR_MODULE_TIME & , 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 GLOBAL_BLR_SAVINGS = TMP_GLOBAL_BLR_SAVINGS ACC_FR_MRY = TMP_ACC_FR_MRY ACC_LR_FLOP_GAIN = TMP_ACC_LR_FLOP_GAIN ACC_FLOP_TRSM = TMP_ACC_FLOP_TRSM ACC_FLOP_PANEL = TMP_ACC_FLOP_PANEL ACC_FLOP_LR_TRSM = TMP_ACC_FLOP_LR_TRSM ACC_FLOP_FR_TRSM = TMP_ACC_FLOP_FR_TRSM ACC_FLOP_LR_UPDT = TMP_ACC_FLOP_LR_UPDT ACC_FLOP_LR_UPDT_OUT = TMP_ACC_FLOP_LR_UPDT_OUT ACC_FLOP_RMB = TMP_ACC_FLOP_RMB ACC_FLOP_DEC_ACC = TMP_ACC_FLOP_DEC_ACC ACC_FLOP_REC_ACC = TMP_ACC_FLOP_REC_ACC ACC_FLOP_FR_UPDT = TMP_ACC_FLOP_FR_UPDT ACC_FLOP_DEMOTE = TMP_ACC_FLOP_DEMOTE ACC_FLOP_CB_DEMOTE = TMP_ACC_FLOP_CB_DEMOTE ACC_FLOP_CB_PROMOTE = TMP_ACC_FLOP_CB_PROMOTE ACC_FLOP_FRFRONTS = TMP_ACC_FLOP_FRFRONTS CNT_NODES = TMP_CNT_NODES ACC_FLOP_FR_FACTO = TMP_ACC_FLOP_FR_FACTO C ACC_FLOP_LR_FACTO = ACC_FLOP_FR_FACTO - ACC_LR_FLOP_GAIN C & + ACC_FLOP_DEMOTE ACC_UPDT_TIME = TMP_ACC_UPDT_TIME /id%NPROCS ACC_DEMOTING_TIME = TMP_ACC_DEMOTING_TIME /id%NPROCS ACC_CB_DEMOTING_TIME = TMP_ACC_CB_DEMOTING_TIME/id%NPROCS ACC_PROMOTING_TIME = TMP_ACC_PROMOTING_TIME /id%NPROCS ACC_FRPANELS_TIME = TMP_ACC_FRPANELS_TIME /id%NPROCS ACC_FAC_I_TIME = TMP_ACC_FAC_I_TIME /id%NPROCS ACC_FAC_MQ_TIME = TMP_ACC_FAC_MQ_TIME /id%NPROCS ACC_FAC_SQ_TIME = TMP_ACC_FAC_SQ_TIME /id%NPROCS ACC_TRSM_TIME = TMP_ACC_TRSM_TIME /id%NPROCS ACC_FRFRONTS_TIME = TMP_ACC_FRFRONTS_TIME /id%NPROCS ACC_LR_MODULE_TIME = TMP_ACC_LR_MODULE_TIME /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110),RINFOG(3),id%NPROCS, & PROKG, MPG) FRONTWISE = 0 IF (id%KEEP(486).EQ.1) THEN C BLR was activated 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, & 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), KEEP(485), KEEP(467), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) ELSE RINFOG(14) = 0.0D00 ENDIF 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 C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(16). C Note that KEEP(17) already has the same value on all procs INFOG(28)=KEEP(112)+KEEP(17) 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 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),id%KEEP8(6),INFOG(10), & 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(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency 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 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 #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 CALL ZMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8, .TRUE.) C INFO(1): input only ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') CALL MUMPS_FDM_END('F') 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 530 is done when an error occurs before C the calls to 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 FOR MATRIX DISTRIBUTION =',F12.4) 166 FORMAT(' Convergence error after scaling 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/ & ' REAL SPACE FOR FACTORS =',I16/ & ' INTEGER SPACE FOR FACTORS =',I16/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I16) 172 FORMAT(/' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' NUMBER OF WORKING PROCESSES =',I16/ & ' OUT-OF-CORE OPTION (ICNTL(22)) =',I16/ & ' REAL SPACE FOR FACTORS =',I16/ & ' INTEGER SPACE FOR FACTORS =',I16/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I16/ & ' NUMBER OF NODES IN THE TREE =',I16/ & ' MEMORY ALLOWED (MB -- 0: N/A ) =',I16/ & ' RELATIVE THRESHOLD FOR PIVOTING, CNTL(1) =',D16.4) 173 FORMAT( ' PERFORM FORWARD DURING FACTO, NRHS =',I16) 175 FORMAT(/' NUMBER OF ENTRIES FOR // ROOT =',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) =',F12.4) 99979 FORMAT( ' RINFOG(12) DETERMINANT (imaginary part) =',F12.4) 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 NULL PIVOTS DETECTED BY ICNTL(16) =',I16) 99991 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(24) =',I16) 99992 FORMAT( ' INFOG(28) ESTIMATED DEFICIENCY =',I16) 99984 FORMAT(/' GLOBAL STATISTICS '/ & ' RINFOG(2) OPERATIONS IN NODE ASSEMBLY =',1PD10.3/ & ' ------(3) OPERATIONS IN NODE ELIMINATION=',1PD10.3/ & ' 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 SUBROUTINE ZMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL PROKG INTEGER MPG INTEGER(8) VAL INTEGER NSLAVES INTEGER COMM CHARACTER*42 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 WRITE(MPG,100) " Maximum ", MSG, MAX_VAL WRITE(MPG,100) " Average ", MSG, int(AVG_VAL,8) ENDIF RETURN 100 FORMAT(A9,A42,I16) 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%NSLAVES) 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.1.2/src/zfac_mem_compress_cb.F0000664000175000017500000002773713164366265020016 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INCLUDE 'mumps_headers.h' 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 SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE ZMUMPS_SIZEFREEINREC 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) IMPLICIT NONE INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER N,LIW,KEEP28, & IWPOS,IWPOSCB,KEEP216,XSIZE INTEGER(8) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER IW(LIW),PTRIST(KEEP28), & STEP(N), PIMASTER(KEEP28) COMPLEX(kind=8) 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 INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE INTEGER IXXP 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 IF ( STATE_NEXT .NE. S_FREE .AND. & (KEEP216.EQ.3.OR. & (STATE_NEXT .NE. S_NOLCBNOCONTIG .AND. & STATE_NEXT .NE. S_NOLCBCONTIG .AND. & STATE_NEXT .NE. S_NOLCBNOCONTIG38 .AND. & STATE_NEXT .NE. S_NOLCBCONTIG38))) THEN CALL ZMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) 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 (RSIZE2SHIFT .NE. 0_8) THEN IF (PTRAST(STEP(INODE)).EQ.RCURRENT) & PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT IF (PAMASTER(STEP(INODE)).EQ.RCURRENT) & PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT 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 IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN IF ( KEEP216.eq.3) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_COMPRE_NEW" ENDIF 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) 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) 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) ELSE 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 INODE=IW(ICURRENT+XXN) IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) IF (STATE_NEXT.EQ.S_NOLCBCONTIG.OR. & STATE_NEXT.EQ.S_NOLCBNOCONTIG) THEN IW(ICURRENT+XXS)=S_NOLCLEANED ELSE IW(ICURRENT+XXS)=S_NOLCLEANED38 ENDIF 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 MUMPS_5.1.2/src/cfac_process_master2.F0000664000175000017500000001472413164366264017734 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, FRERE, & ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE CMUMPS_LOAD 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 ), 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' 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, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, 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 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 IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & SLAVEF) .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(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, & SLAVEF, 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.1.2/src/cfac_b.F0000664000175000017500000001776313164366264015050 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_FAC_B(N, NSTEPS, & A, LA, IW, 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,INTARR,DBLARR, & root, NELT, FRTPTR, FRTELT, COMM_LOAD, & ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB, & DKEEP,PIVNUL_LIST,LPN_LIST & ,LRGROUPS & ) USE CMUMPS_LOAD USE CMUMPS_FAC_PAR_M IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER(8) :: LA INTEGER N,NSTEPS,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA COMPLEX A(LA) REAL RINFO(40) INTEGER LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER BUFR( LBUFR ) INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) INTEGER LRGROUPS(N) REAL CNTL1 INTEGER ICNTL(40) INTEGER INFO(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(LIW), 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(3*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 MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE REAL UULOC INTEGER LP, MPRINT INTEGER NSTK,PTRAST, NBPROCFILS INTEGER PIMASTER, PAMASTER LOGICAL PROK REAL ZERO, ONE DATA ZERO /0.0E0/ DATA ONE /1.0E0/ INTRINSIC int,real,log INTEGER IERR INTEGER NTOTPV, NTOTPVTOT, NMAXNPIV INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT KEEP(41)=0 KEEP(42)=0 NSTEPS = 0 LP = ICNTL(1) MPRINT = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) UULOC = CNTL1 IF (UULOC.GT.ONE) UULOC=ONE IF (UULOC.LT.ZERO) UULOC=ZERO IF (KEEP(50).NE.0.AND.UULOC.GT.0.5E0) THEN UULOC = 0.5E0 ENDIF PIMASTER = 1 NSTK = PIMASTER + KEEP(28) NBPROCFILS = NSTK + 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(67) = LRLUS KEEP8(68) = LRLUS KEEP8(69) = LRLUS KEEP8(70) = LRLUS KEEP8(71) = LRLUS IPTRLU = LRLU NTOTPV = 0 NMAXNPIV = 0 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))), SLAVEF ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF CALL CMUMPS_FAC_PAR(N,IW,LIW,A,LA,IW1(NSTK),IW1(NBPROCFILS), & NFSIZ,FILS,STEP,FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & INFO(11), NTOTPV, NMAXNPIV, 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,NSTEPS,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) & ) 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 ENDIF KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(31), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) KEEP8(68) = LA - KEEP8(68) KEEP8(69) = LA - KEEP8(69) KEEP(89) = NTOTPV KEEP(246) = NMAXNPIV INFO(23) = KEEP(89) 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 in mc51d 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 in mc51d NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(31), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), INFO(25), RINFO(2), RINFO(3) 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/ & ' --- (25) NUMBER OF ENTRIES IN FACTORS =',I15/ & ' RINFO(2) OPERATIONS DURING NODE ASSEMBLY =',1PD10.3/ & ' -----(3) OPERATIONS DURING NODE ELIMINATION =',1PD10.3) END SUBROUTINE CMUMPS_FAC_B MUMPS_5.1.2/src/sfac_mem_stack.F0000664000175000017500000005171413164366262016602 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, & IPOOL, LPOOL, LEAF, NSTK_S, & NBPROCFILS, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, & OPASSW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(40), KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, 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 ), & 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 NBPROCFILS( KEEP(28) ) 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, & NBROW_STACK, NBCOL_STACK, NELIM 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 COMPRESSCB, MUST_COMPACT_FACTORS LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE 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)),SLAVEF) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),SLAVEF) LREQCB = 0_8 INPLACE = .FALSE. COMPRESSCB= ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1) 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(*,*) "COMPRESSCB, NFRONT, NPIV, NASS, NSLAVES", & COMPRESSCB, 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 KEEP8(10) = KEEP8(10) + int(NPIV,8) * int(NFRONT,8) ELSE KEEP8(10) = KEEP8(10) + ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF KEEP8(10) = KEEP8(10) + int(NBROW,8) * int(NPIV,8) 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 ) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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)),SLAVEF) 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, 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, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), SLAVEF ) 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 ), COMPRESSCB, & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)), & SLAVEF) .EQ. MYID ) THEN LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_SEND = 0 IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NBROW ELSE NBCOL_STACK = NBCOL ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBCOL_STACK = NBCOL LREQI = 6 + NBROW_STACK + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (COMPRESSCB) THEN LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 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, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .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 (COMPRESSCB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (COMPRESSCB) 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 ( 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 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, COMPRESSCB, & 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, COMPRESSCB ) 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 NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND 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 KEEP8(8)=KEEP8(8) + int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF 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) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE SMUMPS_FAC_STACK MUMPS_5.1.2/src/ztools.F0000664000175000017500000007652013164366265015202 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 LOGICAL MOVEPTRAST LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR 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 IF (LDLT.EQ.0) THEN SIZECB = int(LCONT,8) * int(LCONT,8) ELSE SIZECB = int(NROW,8) * int(LCONT,8) ENDIF END IF CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZECB ) IF ((SIZECB.EQ.0_8).AND.(KEEP(201).EQ.0)) THEN GOTO 500 ENDIF IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL ZMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) 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 ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF(KEEP(201).EQ.0)THEN PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB ELSE PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) - & SIZECB - SIZELU ENDIF MOVEPTRAST = .TRUE. IF(KEEP(201).EQ.0)THEN PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB ELSE PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB & - SIZELU ENDIF ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF(KEEP(201).EQ.0)THEN PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3))-SIZECB ELSE PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZECB-SIZELU ENDIF ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF(KEEP(201).EQ.0)THEN PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB ELSE PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB & - SIZELU ENDIF END IF IPS = IPS + IPSIZE END DO IF ((SIZECB .NE. 0_8).OR.(KEEP(201).NE.0)) THEN IF (KEEP(201).NE.0) THEN DO I=IAPOS, POSFAC - SIZECB - SIZELU - 1_8 A( I ) = A( I + SIZECB + SIZELU) END DO ELSE DO I=IAPOS + SIZELU, POSFAC - SIZECB - 1_8 A( I ) = A( I + SIZECB ) END DO ENDIF END IF ENDIF IF (KEEP(201).NE.0) THEN POSFAC = POSFAC - (SIZECB+SIZELU) LRLU = LRLU + (SIZECB+SIZELU) LRLUS = LRLUS + (SIZECB+SIZELU) - SIZE_INPLACE KEEP8(70) = KEEP8(70) + (SIZECB+SIZELU) - SIZE_INPLACE KEEP8(71) = KEEP8(71) + (SIZECB+SIZELU) - SIZE_INPLACE ELSE POSFAC = POSFAC - SIZECB LRLU = LRLU + SIZECB LRLUS = LRLUS + SIZECB - SIZE_INPLACE KEEP8(70) = KEEP8(70) + SIZECB - SIZE_INPLACE KEEP8(71) = KEEP8(71) + SIZECB - SIZE_INPLACE IF (LRCOMPRESS_PANEL) THEN KEEP8(71) = KEEP8(71) + SIZELU ENDIF ENDIF 500 CONTINUE CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE,KEEP,KEEP8,LRLUS) 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, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) USE ZMUMPS_OOC USE ZMUMPS_LOAD 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(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) :: LAFAC, 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) 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 )) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS_CB+XXR)) 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_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRAST(STEP(ISON))), LAFAC, 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) 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 ) 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(70) = KEEP8(70) - LREQA KEEP8(68) = min(KEEP8(70), 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+XXI)=LREQI CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXS)=-9999 IW(POSI+XXS+1:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXLR) = LRSTATUS 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 POSALOC = POSA DO I = 1, NROW_L OLDPOS = PTRAST( STEP(ISON)) + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = 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 KEEP8(10) = KEEP8(10) + int(NCOL_L,8) * int(NROW_L,8) 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 KEEP8(70) = KEEP8(70) + LREQA KEEP8(71) = KEEP8(71) + LREQA 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 & ) 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 ISTCHK = PTRIST(STEP(ISON)) CALL ZMUMPS_FREE_BLOCK_CB(.FALSE.,MYID, N, ISTCHK, & PTRAST(STEP(ISON)), & 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_MAX_MEM( KEEP,KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, PERLU_ON, & MEMORY_BYTES ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON INTEGER, INTENT(IN) :: OOC_STRAT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID, N, NELT, NSLAVES, LNA INTEGER(8) :: NA_ELT8, NNZ8 INTEGER(8), INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT) :: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL, MAXS_MIN 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 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 ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MAXS_MIN = KEEP8(14) ELSE MAXS_MIN = KEEP8(12) ENDIF IF ( .NOT. EFF ) THEN IF ( KEEP8(24).EQ.0_8 ) THEN NB_REAL = NB_REAL + MAXS_MIN + & int(PERLU,8)*(MAXS_MIN / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + KEEP8(67) 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 ZMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) ZMUMPS_LBUFR_BYTES8 = max( ZMUMPS_LBUFR_BYTES8, & 100000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF 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(43))-100,8)) NB_BYTES = NB_BYTES + ZMUMPS_LBUFR_BYTES8 ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 43 ) * KEEP( 35 )), 8 ) 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 ZMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(ZMUMPS_LBUF_INT,8) IF ( EFF ) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int(KEEP(225),8) ELSE NB_INT = NB_INT + int(KEEP(15),8) ENDIF ELSE 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(486).NE.0) THEN NB_INT = NB_INT + N8 NB_REAL = NB_REAL + & int(KEEP(127),8)*int(KEEP(488),8) ENDIF END IF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = int( MEMORY_BYTES / 1000000_8 ) + 1 RETURN END SUBROUTINE ZMUMPS_MAX_MEM 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_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,COMPRESSCB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL COMPRESSCB 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) M_ARRAY(1:NMAX) = ZERO APOS = 0_8 IF (COMPRESSCB) 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 (COMPRESSCB) 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) IF (associated(id%IS1)) NB_INT=NB_INT+size(id%IS1) 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%BUFR)) NB_INT=NB_INT+size(id%BUFR) 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%PROCNODE)) NB_INT=NB_INT+size(id%PROCNODE) IF (associated(id%INTARR)) NB_INT=NB_INT+size(id%INTARR) 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_BEFORE_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_BEFORE_L0_OMP) IF (associated(id%IPOOL_AFTER_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_AFTER_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+size(id%DBLARR) IF (associated(id%RHSCOMP)) NB_CMPLX=NB_CMPLX+size(id%RHSCOMP) 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 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_SIZE ) USE ZMUMPS_STATIC_PTR_M INTEGER, INTENT(IN) :: THE_SIZE COMPLEX(kind=8), INTENT(IN) :: THE_ADDRESS(THE_SIZE) CALL ZMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE)) RETURN END SUBROUTINE ZMUMPS_SET_TMP_PTR MUMPS_5.1.2/src/cana_LDLT_preprocess.F0000664000175000017500000007056213164366264017635 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE CMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER N,NCST INTEGER PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N,3) INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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,1) IF(K1 .GT. 0) THEN V1 = (abs(id%A(K1))*(id%ROWSCA(P1)**2).GE.1.0E-1) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2,1) IF(K2 .GT. 0) THEN V2 = (abs(id%A(K2))*(id%ROWSCA(P2)**2).GE.1.0E-1) 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) 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(40) 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) 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.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) 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 & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(40) 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) 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 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE 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 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.1.2/src/dfac_distrib_distentry.F0000664000175000017500000006441113164366263020364 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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))), & SLAVEF ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & SLAVEF ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & SLAVEF ) 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 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( 40 ), ICNTL(40) 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, INEW, JNEW INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 LOGICAL T4_MASTER_CONCERNED DOUBLE PRECISION VAL INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE 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 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 IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60)==0) THEN 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 IF ( PTR_ROOT .LE. LA ) THEN A( PTR_ROOT:LA ) = ZERO END IF ELSE DO I = 1, root%SCHUR_NLOC root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC) = ZERO ENDDO ENDIF 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) DO K8 = 1_8, NZ_loc8 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, & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF 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) ) CYCLE 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 (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 ENDIF ENDIF IARR = abs( ISEND ) ISTEP = abs(STEP(IARR)) TYPE_NODE = MUMPS_TYPENODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE= MUMPS_PROCNODE( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & SLAVEF ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF (TYPE_NODE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF ELSE 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 END IF if (DEST .eq. -1) 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 end if IF ( DEST.EQ.-1) THEN DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDDO 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, ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDIF ELSE 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, ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), & root, KEEP,KEEP8 ) ENDIF ENDIF END DO DEST = -2 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, ARROW_ROOT, 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, & ARROW_ROOT, 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, ARROW_ROOT, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, & KEEP,KEEP8 ) IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER ARROW_ROOT, 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. -2 ) 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. -2 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -2 .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, & ARROW_ROOT, 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. -2 ) 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, & ARROW_ROOT, 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, ARROW_ROOT, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER NBRECORDS, N, ARROW_ROOT, 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, IROW_GRID, JCOL_GRID, & ILOCROOT, JLOCROOT INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT, IARR, JARR INTEGER TAILLE DOUBLE PRECISION VAL 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 )))), & SLAVEF ) IF ( NODE_TYPE .eq. 3 ) THEN ARROW_ROOT = ARROW_ROOT + 1 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 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .NE. root%MYROW .OR. & JCOL_GRID .NE. root%MYCOL ) THEN WRITE(*,*) MYID,':INTERNAL Error: recvd root arrowhead ' WRITE(*,*) MYID,':not belonging to me. IARR,JARR=',IARR,JARR WRITE(*,*) MYID,':IROW_GRID,JCOL_GRID=',IROW_GRID,JCOL_GRID WRITE(*,*) MYID,':MYROW, MYCOL=', root%MYROW, root%MYCOL WRITE(*,*) MYID,':IPOSROOT,JPOSROOT=', IPOSROOT, JPOSROOT CALL MUMPS_ABORT() 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 IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) & .AND. & IW4(IARR,1) .EQ. 0 .AND. & IPROC .EQ. MYID & .AND. STEP(IARR) > 0 ) 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 ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE DMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.1.2/src/zfac_front_LU_type1.F0000664000175000017500000005060113164366266017516 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS & , LRGROUPS & ) 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 !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR, NOFFW, NPVW 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) 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 DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVOT_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 CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM INTEGER T1, T2, COUNT_RATE, T1P, T2P, CRP INTEGER TTOT1, TTOT2, COUNT_RATETOT INTEGER TTOT1FR, TTOT2FR, COUNT_RATETOTFR DOUBLE PRECISION :: LOC_UPDT_TIME, & LOC_PROMOTING_TIME, LOC_DEMOTING_TIME, & LOC_CB_DEMOTING_TIME, LOC_FRPANELS_TIME, & LOC_TRSM_TIME, & LOC_FRFRONTS_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, LOC_FAC_SQ_TIME INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok INTEGER :: OMP_NUM INCLUDE 'mumps_headers.h' IF (KEEP(486).NE.0) THEN LOC_UPDT_TIME = 0.D0 LOC_PROMOTING_TIME = 0.D0 LOC_DEMOTING_TIME = 0.D0 LOC_CB_DEMOTING_TIME = 0.D0 LOC_FRPANELS_TIME = 0.0D0 LOC_FRFRONTS_TIME = 0.0D0 LOC_TRSM_TIME = 0.D0 LOC_LR_MODULE_TIME = 0.D0 LOC_FAC_I_TIME = 0.D0 LOC_FAC_MQ_TIME = 0.D0 LOC_FAC_SQ_TIME = 0.D0 ENDIF 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) 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(BEGS_BLR) 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 (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 IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) 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 PIVOT_OPTION = 4 CNT_NODES = CNT_NODES + 1 CALL INIT_STATS_FRONT(NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1) ELSE IF (KEEP(486).GT.0) THEN CALL INIT_STATS_FRONT(-NFRONT, STEP_STATS(INODE), NASS, & NFRONT-NASS) CALL SYSTEM_CLOCK(TTOT1FR) ENDIF IF (KEEP(201).EQ.1) THEN IF (PIVOT_OPTION.LT.3) PIVOT_OPTION=3 ENDIF 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) 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 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 ENDIF ENDIF IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1) ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF CALL ZMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW, & 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 & ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_I_TIME = LOC_FAC_I_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) ENDIF 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) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_MQ_TIME = LOC_FAC_MQ_TIME + & dble(T2P-T1P)/dble(CRP) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( (KEEP(201).EQ.1).AND.(PIVOT_OPTION.GE.3) & .AND. & ( .NOT. LR_ACTIVATED .OR. (.NOT. COMPRESS_PANEL) .OR. & (KEEP(485).EQ.0) & ) & ) 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 (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T1P) END IF 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, .FALSE., .TRUE., & .FALSE. ) IF (LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(T2P,CRP) LOC_FAC_SQ_TIME = LOC_FAC_SQ_TIME + & dble(T2P-T1P)/dble(CRP) END IF 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, (PIVOT_OPTION.LT.2), .TRUE., & .FALSE. ) ENDIF ELSE CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_FRPANELS_TIME = LOC_FRPANELS_TIME + & dble(T2-T1)/dble(COUNT_RATE) CALL UPDATE_FLOP_STATS_PANEL(NFRONT - IBEG_BLR + 1, & NPIV - IBEG_BLR + 1, 1, 0) NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN GOTO 100 ENDIF CALL SYSTEM_CLOCK(T1) IF (IEND_BLR.LT.NFRONT .AND. PIVOT_OPTION.EQ.4) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & -66666, & A, LA, POSELT, .FALSE., .FALSE., & .FALSE. ) ENDIF CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_TRSM_TIME = LOC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR)) ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) IF (IFLAG.LT.0) GOTO 400 CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(473), BLR_L, CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP(470), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_DEMOTING_TIME = LOC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #endif 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(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_UPDT_TIME = LOC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H', 1) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V', 1) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & .FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) END IF IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & . FALSE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', NFRONT, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) LOC_PROMOTING_TIME = LOC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8, & .TRUE.) DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF (KEEP(201).EQ.1) 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 IF (COMPRESS_CB) THEN CALL ZMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, NPARTSCB+NPARTSASS, & BEGS_BLR, NPARTSCB+NPARTSASS, NPARTSASS, & DKEEP(8), NASS, NFRONT-NASS, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, STEP_STATS(INODE), 1, & .FALSE., 0, KEEP(484)) ENDIF CALL SYSTEM_CLOCK(TTOT2,COUNT_RATETOT) CALL STATS_COMPUTE_MRY_FRONT_TYPE1(NASS, NFRONT-NASS, & KEEP(50), INODE, NASS-NPIV) CALL STATS_COMPUTE_FLOP_FRONT_TYPE1(NFRONT, NASS, NPIV, & KEEP(50), INODE) LOC_LR_MODULE_TIME = DBLE(TTOT2-TTOT1)/DBLE(COUNT_RATETOT) DEALLOCATE(WORK) DEALLOCATE(RWORK) DEALLOCATE(TAU) DEALLOCATE(JPVT) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF 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, LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL SYSTEM_CLOCK(TTOT2FR,COUNT_RATETOTFR) LOC_FRFRONTS_TIME = & DBLE(TTOT2FR-TTOT1FR)/DBLE(COUNT_RATETOTFR) CALL UPDATE_FLOP_STATS_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF CALL UPDATE_ALL_TIMES(INODE,LOC_UPDT_TIME,LOC_PROMOTING_TIME, & LOC_DEMOTING_TIME, LOC_CB_DEMOTING_TIME, & LOC_FRPANELS_TIME, LOC_FRFRONTS_TIME, & LOC_TRSM_TIME, LOC_LR_MODULE_TIME, & LOC_FAC_I_TIME, LOC_FAC_MQ_TIME, & LOC_FAC_SQ_TIME) ENDIF IF (KEEP(201).EQ.1) 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 500 490 CONTINUE write(*,*) 'Allocation problem in BLR routine & ZMUMPS_FAC_FRONT_LU_TYPE1: ', & 'not enough memory? memory requested = ' , IERROR 500 CONTINUE NPVW = NPVW + IW(IOLDPS+1+XSIZE) RETURN END SUBROUTINE ZMUMPS_FAC1_LU END MODULE ZMUMPS_FAC1_LU_M MUMPS_5.1.2/src/dsol_bwd.F0000664000175000017500000012210113164366264015427 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NA, LNA, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, 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 & , TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE DMUMPS_OOC USE DMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER(8), intent(in) :: LWC INTEGER N,LIW,LIWW,LPOOL,LNA INTEGER SLAVEF,MYLEAF,COMM,MYID INTEGER LPANEL_POS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NA(LNA),NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(40), INFO(40) 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) #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION RHSCOMP(NRHS,LRHSCOMP) #else DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) #endif INTEGER(8), intent(in) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) 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 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INTEGER POSIWCB,K INTEGER(8) :: APOS, IST INTEGER(8) :: IFR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB,NBFINF INTEGER NBLEAF,INODE,NBROOT,NROOT,NBFILS INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER III,IIPOOL,MYLEAFE INTEGER NSLAVES INTEGER JBDEB, JBFIN, NRHS_B DOUBLE PRECISION ALPHA,ONE,ZERO PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) LOGICAL BLOQ,DEBUT INTEGER PROCDEST, DEST INTEGER POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL, & IPOSINRHSCOMP_TMP INTEGER DUMMY(1) INTEGER(8) :: POSWCB, PLEFTW, PTWCB INTEGER Offset, EffectiveSize, ISLAVE, FirstIndex LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INCLUDE 'mumps_headers.h' LOGICAL BLOCK_SEQUENCE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL Exploit_Sparsity, AM1 DOUBLE PRECISION :: TIME_TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok 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 LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER MUMPS_TYPENODE EXTERNAL dgemv, dtrsv, dtrsm, dgemm, & MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR 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 NROOT = 0 NBLEAF = NA(1) NBROOT = NA(2) DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) .EQ. MYID) THEN NROOT = NROOT + 1 IPOOL(NROOT) = INODE ENDIF END DO III = 1 IIPOOL = NROOT + 1 BLOCK_SEQUENCE = .FALSE. Exploit_Sparsity = .FALSE. AM1 = .FALSE. IF (KEEP(235).NE.0) Exploit_Sparsity = .TRUE. IF (KEEP(237).NE.0) AM1 = .TRUE. NO_CHILDREN = .FALSE. IF (Exploit_Sparsity .OR. AM1) MYLEAF = -1 IF (MYLEAF .EQ. -1) THEN MYLEAF = 0 DO I=1, NBLEAF INODE=NA(I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) .EQ. MYID) THEN MYLEAF = MYLEAF + 1 ENDIF ENDDO ENDIF MYLEAFE=MYLEAF NBFINF = SLAVEF IF (MYLEAFE .EQ. 0) THEN CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) THEN GOTO 340 ENDIF ENDIF 50 CONTINUE 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , 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 GO TO 60 ENDIF END IF IF ( NBFINF .eq. 0 ) GOTO 340 GOTO 50 IF (MYID.EQ.0) write(6,*) "BWD: process INODE=", INODE 60 CONTINUE 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO JJ = J1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP_TMP) = RHS_ROOT(IFR+NPIV*(K-1)) #else RHSCOMP(IPOSINRHSCOMP_TMP,K) = RHS_ROOT(IFR+NPIV*(K-1)) #endif END DO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE CALL DMUMPS_SOL_CPY_FS2RHSCOMP(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) ENDIF IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 ENDIF GOTO 50 ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( AM1 ) 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 DEBUT = .TRUE. DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( AM1 ) 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)),SLAVEF) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & SLAVEF) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) GOTO 330 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF ( IERR .NE. 0 ) CALL MUMPS_ABORT() ENDIF IF = FRERE(STEP(IF)) ENDDO IF (AM1 .AND.NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 ENDIF 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 GOTO 50 END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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)) GOTO 330 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 330 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2 - KEEP(253) J = IW(JJ) IFR = IFR + 1_8 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN W(IFR+int(K-JBDEB,8)*int(NCB,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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) ELSE WRITE(*,*) "Internal error DMUMPS_SOL_S" CALL MUMPS_ABORT() END IF 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 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) GOTO 50 ENDIF 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) 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 330 ENDIF ENDIF APOS = PTRFAC(IW(IPOS)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1) 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)) GOTO 330 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) ) GOTO 330 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 330 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(350).eq.0) THEN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = ZERO ENDDO ELSE DO JJ = J1, J2 #if defined(RHSCOMP_BYROWS) W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif ENDDO ENDIF ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = ZERO ENDDO ENDIF ELSE WRITE(*,*) "Internal error DMUMPS_SOL_BWD" CALL MUMPS_ABORT() 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 IF (KEEP(350).EQ.0) THEN DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1_8 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) DO K=JBDEB, JBFIN W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif ENDDO ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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) ELSE WRITE(*,*) "Internal error DMUMPS_SOL_S" CALL MUMPS_ABORT() ENDIF 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) 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 (KEEP(350).EQ.0) THEN CALL dgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( PTWCB_PANEL+int(NBJ,8) ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ELSE IF (NCB_PANEL - NCB.NE. 0) THEN CALL dgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), & 1, ONE, & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif 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, # if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) # else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) # endif ENDIF ENDIF ENDIF IF (MTYPE.NE.1) THEN IF (KEEP(350).eq.0) THEN CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ELSE IF (KEEP(350).eq.0) THEN CALL dtrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL dtrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) #else & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) #endif ENDIF ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (KEEP(350).eq.0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(PTWCB_PANEL+int(NBJ,8)),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in DMUMPS_SOL_S" CALL MUMPS_ABORT() #else 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 ENDIF ENDIF IF (MTYPE.NE.1) THEN IF (KEEP(350).eq.0) THEN CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in DMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF ELSE IF (KEEP(350).eq.0) THEN CALL dtrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in DMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL dtrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #endif ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ENDIF IF (KEEP(201).EQ.0.OR.KEEP(201).EQ.2)THEN 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 IF (KEEP(350).EQ.0) THEN CALL dgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & W(PTWCB), 1 ) ELSE CALL dgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL dgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & W(PTWCB), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in DMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL dgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #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 IF (KEEP(350).EQ.0) THEN CALL dgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB+int(NPIV,8) ), & 1, ONE, & W(PTWCB), 1 ) ELSE CALL dgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL dgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, W(PTWCB),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in DMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL dgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB),LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL dtrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL dtrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL dtrsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), & LIELL, W(PTWCB), LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in DMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL dtrsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), & LIELL, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE LDAJ=NPIV ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (KEEP(350).EQ.0) THEN CALL dtrsv('U','N','U', NPIV, A(APOS), LDAJ, & W(PTWCB), 1) ELSE CALL dtrsv('U','N','U', NPIV, A(APOS), LDAJ, #if defined(RHSCOMP_BYROWS) & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) #else & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) #endif ENDIF ELSE #endif IF (KEEP(350).EQ.0) THEN CALL dtrsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), & LDAJ,W(PTWCB),LIELL) ELSE #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in DMUMPS_SOL_S" CALL MUMPS_ABORT() #else CALL dtrsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), & LDAJ, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #endif ENDIF #if defined(MUMPS_USE_BLAS2) END IF #endif END IF 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)) IF (KEEP(350).EQ.0) THEN IPOSINRHSCOMP_TMP = IPOSINRHSCOMP DO 150 I = 1, NPIV DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP_TMP) = W(PTWCB+I-1+(K-JBDEB)*LIELL) #else RHSCOMP(IPOSINRHSCOMP_TMP, K) = W(PTWCB+I-1+(K-JBDEB)*LIELL) #endif ENDDO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 150 CONTINUE ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN ELSE WRITE(*,*)"Internal error in DMUMPS_SOL_S" CALL MUMPS_ABORT() ENDIF 160 CONTINUE IF (KEEP(201).GT.0) 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 330 ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 ENDIF GOTO 50 ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF (AM1) 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 ( AM1 ) 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 (AM1 .AND. NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 ENDIF ENDIF ELSE DEBUT = .TRUE. DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( AM1 ) 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)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),SLAVEF) 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, MYLEAFE, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) GOTO 330 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF (AM1 .AND. NO_CHILDREN) THEN MYLEAFE = MYLEAFE - 1 IF (MYLEAFE .EQ. 0) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF, KEEP ) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) GOTO 340 GOTO 50 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 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 GOTO 50 330 CONTINUE CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, & SLAVEF, KEEP) 340 CONTINUE CALL DMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE DMUMPS_SOL_S MUMPS_5.1.2/src/dfac_mem_stack_aux.F0000664000175000017500000001541613164366263017440 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, COMPRESSCB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: COMPRESSCB 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. COMPRESSCB ) 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. COMPRESSCB) 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, COMPRESSCB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: COMPRESSCB 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 > 300) DO I = 1, NBROW_STACK IF (COMPRESSCB) 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. COMPRESSCB) 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.1.2/src/zana_reordertree.F0000664000175000017500000012346513164366265017204 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, & 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 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(40) 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)), & SLAVEF))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)), & SLAVEF))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)), & SLAVEF))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)), & SLAVEF))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)),SLAVEF))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)),SLAVEF)))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)),SLAVEF)))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, & 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 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(40) 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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))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)),SLAVEF))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),SLAVEF) 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)),SLAVEF) 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)),SLAVEF))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)),SLAVEF) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE WRITE(*,*)ID,': INODE -> ',INODE,'DF =', & CUR_DEPTH_FIRST_RANK CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & SLAVEF))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & SLAVEF))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.1.2/src/fac_asm_build_sort_index_m.F0000664000175000017500000005134413164366241021161 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE_STEPS, & SON_LEVEL2, NIV1, NBPROCFILS, 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 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)), & NBPROCFILS(KEEP(28)), PERM(N) INTEGER, TARGET :: IW(LIW) INTEGER, INTENT(IN), TARGET :: IWPOSCB 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 #if ! defined(NO_XXNBPR) INTEGER INBPROCFILS_SON #endif INTEGER TYPESPLIT INCLUDE 'mumps_headers.h' INTEGER, POINTER :: SON_IWPOSCB INTEGER, POINTER, DIMENSION(:) :: SON_IW INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTTRI, PTLAST INTEGER MUMPS_TYPESPLIT, MUMPS_TYPENODE EXTERNAL MUMPS_TYPESPLIT, MUMPS_TYPENODE #if ! defined(NO_XXNBPR) IW(IOLDPS+XXNBPR) = 0 #endif TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & SLAVEF) 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)),SLAVEF) J= MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(IFSON)), & SLAVEF) 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 #if ! defined(NO_XXNBPR) IF (PIMASTER(STEP(IFSON)) .GT. IWPOSCB) THEN INBPROCFILS_SON = PIMASTER(STEP(IFSON))+XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(IFSON))+XXNBPR ENDIF #endif NBPROCFILS(STEP(IFSON)) = NSLSON NBPROCFILS(STEP(INODE)) = NSLSON #if ! defined(NO_XXNBPR) IW(IOLDPS+XXNBPR)=NSLSON IW(INBPROCFILS_SON) = NSLSON CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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 ALLOCATE(PTTRI(NUMSTK+1), stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 GOTO 800 ENDIF ALLOCATE(PTLAST(NUMSTK+1), stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 GOTO 800 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 ! defined(NO_XXNBPR) IF (PIMASTER(STEP(ISON)).GT.IWPOSCB) THEN INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ENDIF #endif IF (NIV1) THEN NBPROCFILS(STEP(ISON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON #if ! defined(NO_XXNBPR) IW(INBPROCFILS_SON) = NSLSON IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + NSLSON CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) CALL CHECK_EQUAL(NBPROCFILS(STEP(ISON)),IW(INBPROCFILS_SON)) #endif ELSE IF (LEVEL1_SON) THEN NBPROCFILS(STEP(ISON)) = 1 #if ! defined(NO_XXNBPR) IW(INBPROCFILS_SON) = 1 #endif ELSE NBPROCFILS(STEP(ISON)) = NSLSON #if ! defined(NO_XXNBPR) IW(INBPROCFILS_SON) = NSLSON #endif ENDIF NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(ISON)) #if ! defined(NO_XXNBPR) IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + IW(INBPROCFILS_SON) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)),IW(IOLDPS+XXNBPR)) #endif 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)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .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 WRITE(*,*) "Internal error in MUMPS_BUILD_SORT_INDEX", & 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_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(PTTRI)) DEALLOCATE(PTTRI) IF (allocated(PTLAST)) DEALLOCATE(PTLAST) 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.1.2/src/mumps_tags.h0000664000175000017500000001067513164366241016062 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 PARAMETER( RACINE_SOLVE = 14, & ContVec = 11, & Master2Slave = 12, & GatherSol = 13, & ScatterRhsI = 54, & ScatterRhsR = 55) C ----------------------------------------- C Tags for backsolve C ----------------------------------------- INTEGER FEUILLE, & BACKSLV_UPDATERHS, & BACKSLV_MASTER2SLAVE PARAMETER( FEUILLE = 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.1.2/src/dsol_fwd_aux.F0000664000175000017500000014007213164366264016317 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, III, 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_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, III, LEAF, NBFIN, LRHSCOMP INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 40 ), 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 ) #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION RHSCOMP( NRHS, LRHSCOMP ) #else DOUBLE PRECISION RHSCOMP( LRHSCOMP, NRHS ) #endif 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 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 DOUBLE PRECISION :: TIME_TMP 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 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'Internal error 41r2 : Pool is too small.' CALL MUMPS_ABORT() END IF END IF 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))) #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) = & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + & WCB(PLEFTWCB+I-1) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) = & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) #endif ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF IF ( PTRICB(STEP(FINODE)) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'Internal error 41r2 : Pool is too small.' CALL MUMPS_ABORT() END IF ENDIF END IF 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 + (NPIV + NCV) * NRHS_B 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 IF (KEEP(201).GT.0) 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 APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201).EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE #endif CALL dgemm( 'N', 'N', NCV, NRHS_B, NPIV, ALPHA, & A(APOS), NCV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE #endif CALL dgemm( 'T', 'N', NCV, NRHS_B, NPIV, ALPHA, & A(APOS), NPIV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF IF (KEEP(201).GT.0) 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 - NPIV * NRHS_B PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & SLAVEF ) 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 IF (KEEP(350).EQ.0) THEN DO I = 1, NCV JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) DO K=1, NRHS_B #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + & WCB(PTRY+I-1+(K-1)*NCV) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PTRY+I-1+(K-1)*NCV) #endif ENDDO END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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)) #if defined(RHSCOMP_BYROWS) RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) #else RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) #endif & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF PTRICB(STEP(FINODE)) = & PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) 'INTERNAL Error 41r: Pool is too small.' 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, III, 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 - NCV * NRHS_B 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( INODE, & BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, III, 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, & MYROOT, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP ) USE DMUMPS_OOC USE DMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER INODE, LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, III, LEAF, NBFIN INTEGER MYROOT INTEGER INFO( 40 ), 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 ) DOUBLE PRECISION RHS_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 #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION RHSCOMP(NRHS, LRHSCOMP) #else DOUBLE PRECISION RHSCOMP(LRHSCOMP, NRHS) #endif DOUBLE PRECISION VALPIV, A11, A22, A12, DETPIV LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP 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) DOUBLE PRECISION TIME_TMP INTEGER JBDEB, JBFIN, NRHS_B INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, & IERR, & LIELL, JJ, & NELIM INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: POSWCB1, POSWCB2 INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, & JFIN, NBJ, NUPDATE_PANEL, & NBK, NBK_ini, TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB INTEGER LDAJ, LDAJ_ini, LDAJ_FIRST_PANEL INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY( 1 ) DUMMY(1)=1 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 (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) 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+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 ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSCOMP_TMP = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.0) THEN DO JJ = J1, J3 IFR8 = IFR8 + 1_8 DO K=JBDEB,JBFIN RHS_ROOT(IFR8+int(NPIV,8)*int(K-1,8)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP) #else & RHSCOMP(IPOSINRHSCOMP_TMP,K) #endif END DO IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 END DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 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)) = #if defined(RHSCOMP_BYROWS) & RHSCOMP(K,IPOSINRHSCOMP_TMP+JJ-J1) #else & RHSCOMP(IPOSINRHSCOMP_TMP+JJ-J1,K) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error in SOLVE_NODE for Root node' CALL MUMPS_ABORT() END IF MYROOT = MYROOT - 1 IF ( MYROOT .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 GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF (KEEP(201).EQ.1) 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 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 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)) GO TO 260 END IF IF (KEEP(201).EQ.1) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV DO K=JBDEB, JBFIN IFR8 = PPIV_COURANT+int(K-JBDEB,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 #if defined(RHSCOMP_BYROWS) WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) #endif IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDDO IF (NCB.GT.0) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) #if defined(RHSCOMP_BYROWS) WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) RHSCOMP (K,IPOSINRHSCOMP) = ZERO #else WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP (IPOSINRHSCOMP,K) = ZERO #endif ENDDO ENDIF ENDDO ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.0) THEN !$ OMP_FLAG = NRHS_B.GT.4 .AND. .FALSE. !$OMP PARALLEL DO PRIVATE(J,IFR8,K) IF(OMP_FLAG) DO 130 JJ = J1, J3 J = IW(JJ) IFR8 = IFR_ini8 + int(JJ-J1+1,8) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) WCB(IFR8+(K-JBDEB)*NPIV) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else WCB(IFR8+(K-JBDEB)*NPIV) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif END DO 130 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(JJ,IFR8) IF(OMP_FLAG) DO K=JBDEB, JBFIN IFR8 = IFR_ini8 + (K-JBDEB)*NPIV DO JJ = J1, J3 #if defined(RHSCOMP_BYROWS) WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) #else WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF IFR8 = PCB_COURANT - 1_8 IF (NPIV .LT. LIELL) THEN IFR_ini8 = IFR8 IF (KEEP(350).EQ.0) THEN !$OMP PARALLEL DO PRIVATE(J,IFR8,K,IPOSINRHSCOMP) IF(OMP_FLAG) DO 140 JJ = J3 + 1, J2 J = IW(JJ) IFR8 = IFR_ini8 + (JJ-J3) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(IPOSINRHSCOMP,K) #endif #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP)=ZERO #else RHSCOMP(IPOSINRHSCOMP,K)=ZERO #endif ENDDO 140 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J2-J3)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP) IF (OMP_FLAG) DO K=JBDEB, JBFIN IFR8 = IFR_ini8+(K-JBDEB)*NCB DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) #if defined(RHSCOMP_BYROWS) WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(K,IPOSINRHSCOMP) #else WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(IPOSINRHSCOMP,K) #endif #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP)=ZERO #else RHSCOMP(IPOSINRHSCOMP,K)=ZERO #endif ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (KEEP(201).EQ.1) 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 (KEEP(50).NE.0) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), NPIV, WCB(PPIV_COURANT), & NPIV ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1) THEN CALL dtrsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV ) #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), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm('L','L','N','N',NPIV, NRHS_B, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV) #if defined(MUMPS_USE_BLAS2) ENDIF #endif END IF END IF 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 ( NPIV .NE. 0 .AND. NUPDATE.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), & NPIV, WCB(PPIV_COURANT), 1, ONE, & WCB(PCB_COURANT), 1) ELSE #endif CALL dgemm('T', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), & LIELL, WCB(PPIV_COURANT), 1, & ONE, WCB(PCB_COURANT), 1 ) ELSE #endif CALL dgemm('N', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF END IF IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN IF (KEEP(350).EQ.0) THEN DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + int(K-JBDEB,8)*int(LD_WCBPIV,8) #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1) = #else RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1,K) = #endif & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN #if defined(RHSCOMP_BYROWS) !$ OMP_FLAG = (NPIV.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8,K) IF (OMP_FLAG) DO I=1,NPIV IFR8 = PPIV_COURANT + I-1 DO K=JBDEB,JBFIN RHSCOMP(K,IPOSINRHSCOMP+I-1) = & WCB(IFR8+(K-JBDEB)*LD_WCBPIV) ENDDO ENDDO !$OMP END PARALLEL DO #else !$ 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 #endif ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1) THEN LDAJ = TempNROW ELSE LDAJ = NPIV ENDIF APOS1 = APOS JJ = J1 IF (KEEP(201).EQ.1) THEN NBK = 0 ENDIF IF (KEEP(350).EQ.0) THEN DO IF(JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF(IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV #else RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV #endif END DO IF (KEEP(201).EQ.1) 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) THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1) 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 DO K=JBDEB, JBFIN POSWCB1 = IFR8+int(K-JBDEB,8)*int(LD_WCBPIV,8) POSWCB2 = POSWCB1+1_8 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #endif END DO IF (KEEP(201).EQ.1) 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 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1) 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 ) #if defined(RHSCOMP_BYROWS) RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = & WCB( IFR8 ) * VALPIV #else RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV #endif IF (KEEP(201).EQ.1) 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) THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1) 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 #if defined(RHSCOMP_BYROWS) RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #else RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 #endif IF (KEEP(201).EQ.1) 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 ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF END IF IF (KEEP(201).GT.0) 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 END IF FPERE = DAD(STEP(INODE)) IF ( FPERE .EQ. 0 ) THEN MYROOT = MYROOT - 1 PLEFTWCB = PLEFTWCB - LIELL *NRHS_B IF ( MYROOT .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 GO TO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 IF (KEEP(350).EQ.0) THEN !$ OMP_FLAG = .FALSE. !$OMP PARALLEL DO PRIVATE(K,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) DO 190 I = 1, NUPDATE IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) DO K=JBDEB, JBFIN #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & RHSCOMP( K, IPOSINRHSCOMP_TMP ) #else RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) #endif & + WCB(PCB_COURANT + I-1 +(K-JBDEB)*LD_WCBCB) ENDDO 190 CONTINUE !$OMP END PARALLEL DO ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NUPDATE*(JBFIN-JBDEB+1) .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 IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) #if defined(RHSCOMP_BYROWS) RHSCOMP( K, IPOSINRHSCOMP_TMP ) = & RHSCOMP( K, IPOSINRHSCOMP_TMP ) #else RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) #endif & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO ELSE WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" CALL MUMPS_ABORT() ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE IF ( PTRICB(STEP(INODE)) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 ENDIF END IF ELSE PTRICB(STEP( INODE )) = -1 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 ENDIF 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)), SLAVEF), & 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, III, 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 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) GOTO 260 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, III, 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 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) GOTO 260 END IF END DO END IF PLEFTWCB = PLEFTWCB - LIELL*NRHS_B 270 CONTINUE RETURN 260 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_SOLVE_NODE RECURSIVE SUBROUTINE DMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, III, 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, III, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 40 ), 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) #if defined(RHSCOMP_BYROWS) DOUBLE PRECISION RHSCOMP(NRHS,LRHSCOMP) #else DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) #endif LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN DOUBLE PRECISION :: TIME_TMP 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 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, III, 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 MUMPS_5.1.2/src/fac_descband_data_m.F0000664000175000017500000001235713164366241017521 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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.1.2/src/dmumps_comm_buffer.F0000664000175000017500000036007313164366264017517 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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 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 :: 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 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 ) 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) 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 INCLUDE 'mpif.h' INTEGER :: IERR 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) 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 ) CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), IERR ) 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, COMPRESSCB, & 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 COMPRESSCB INCLUDE 'mpif.h' 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) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR) 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 (COMPRESSCB) 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 (COMPRESSCB) 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 ) 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 ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (COMPRESSCB) 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 ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (COMPRESSCB) 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 ) 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 ) 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 ) 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 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 ) 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 ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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 ) ) # if defined(RHSCOMP_BYROWS) DOUBLE PRECISION RHSCOMP(NRHS,LRHSCOMP) # else DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) # endif INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' 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 ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR ) 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 ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) IF (NODE2.EQ.0.AND.KEEP(350).NE.0) THEN DO K=1, NRHS_B #if defined(RHSCOMP_BYROWS) WRITE(*,*) "Internal error in DMUMPS_BUF_SEND_VCB" CALL MUMPS_ABORT() #else 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 ) 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 ) ENDIF #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 ) 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 ) 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 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 ) 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 ) KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR ) 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 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 ) 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 :: 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 ) 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, & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , LRSTATUS &) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER INODE INTEGER NLIG, NCOL, NASS, NSLAVES 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 SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE_INT = ( 7 + NLIG + NCOL + NSLAVES + 1 ) SIZE_INT = SIZE_INT + 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 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 ) 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 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 ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR) 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 ) 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 ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & COMPRESSCB, KEEP253_LOC ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC INTEGER IPERE, ISON, NBROW 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( * ) LOGICAL DESC_IN_LU, COMPRESSCB 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 NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX INTEGER NBROWS_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: SIZFR, ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, 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) PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO = 0.0D0) 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) CALL MUMPS_GETI8( SIZFR, IW_CBSON( 1 + XXR ) ) 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, PS1, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_DOUBLE_PRECISION, & COMM, SIZE1, IERR ) ENDIF SIZE1 = SIZE1+PS1 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 CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR ) 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, & min( NBROWS_PACKET, NBROW - NBROWS_ALREADY_SENT)) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET * LROW ELSE SIZE_REALS = ( LROW + PERM(1) + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET + ( NBROWS_PACKET * ( NBROWS_PACKET + 1) ) / 2 MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET-1 ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET CALL MPI_PACK_SIZE( SIZE_REALS, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR) IF (SIZE2 + SIZE3 .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 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) & 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 ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 ) 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 ) ENDDO 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 ) ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( COMPRESSCB ) 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 ( COMPRESSCB ) 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 ) ENDDO 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 ) IF(NFS4FATHER .GT. 0) THEN 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 (COMPRESSCB) 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 (COMPRESSCB) 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 = SIZFR - (SHIFTCB_SON - & int(PS1-1,8) * LDA_SON8) LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC .NE. 0 ) THEN CALL DMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC, & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR ) 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 ) 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 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 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 ) 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 ) 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, & SEND_LR, 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) :: SEND_LR INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER :: SEND_LR_INT INTEGER, intent(inout) :: IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' 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 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 ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR ) 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 ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF END IF SIZE2 = 0 CALL MPI_PACK_SIZE(4, MPI_INTEGER, COMM, SIZE3, IERR) SIZE2=SIZE2+SIZE3 IF ( KEEP(50).NE.0 ) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, COMM, SIZE3, IERR) SIZE2=SIZE2+SIZE3 ENDIF IF ((NPIV.GT.0) & ) THEN IF (.NOT. SEND_LR) THEN CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_DOUBLE_PRECISION, & COMM, SIZE3, IERR ) SIZE2 = SIZE2+SIZE3 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), MPI_DOUBLE_PRECISION, & COMM, SIZE3, IERR ) 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 ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR ) 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 ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( LASTBL .or. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) THEN SEND_LR_INT=1 ELSE SEND_LR_INT=0 ENDIF CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) ENDIF IF (SEND_LR) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) END DO CALL MUMPS_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 ) END DO ENDIF ENDIF CALL MPI_PACK( LRELAY_INFO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF ( LRELAY_INFO.GT.0) & CALL MPI_PACK( RELAY_INFO, LRELAY_INFO, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) 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 ) 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 ) 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, & SEND_LR, 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) :: SEND_LR 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) INTEGER :: SEND_LR_INT INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' 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 ) SIZE2 = 0 CALL MPI_PACK_SIZE(2, MPI_INTEGER, COMM, SSLR, IERR) SIZE2=SIZE2+SSLR IF (.NOT. SEND_LR) THEN CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_DOUBLE_PRECISION, & COMM, SSLR, IERR ) 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 ) 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 ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) THEN SEND_LR_INT=1 ELSE SEND_LR_INT=0 ENDIF CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR ) IF (SEND_LR) 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 ) 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 ) 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, DIMENSION(:) :: RG2L_ROW INTEGER, DIMENSION(:) :: RG2L_COL 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 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 ) 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) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_DOUBLE_PRECISION, COMM, & SIZE_TMP, IERR) 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 ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR ) 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 ! defined(DBG_SMB3) 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 #endif ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR ) 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 ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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.1.2/src/zmumps_save_restore.F0000664000175000017500000000071713164366266017760 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_SAVE_RESTORE_RETURN() RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_RETURN MUMPS_5.1.2/src/zfac_mem_free_block_cb.F0000664000175000017500000000553513164366265020246 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_FREE_BLOCK_CB(SSARBR, MYID, N, IPOSBLOCK, & RPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER(8) :: RPOSBLOCK 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 INCLUDE 'mumps_headers.h' IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ) SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) ) 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 ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF ENDIF 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 IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF ENDIF 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 MUMPS_5.1.2/src/zini_driver.F0000664000175000017500000001747513164366266016201 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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" 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 C Reception buffer initialized to zero NULLIFY(id%BUFR) C id%MAXIS1 = 0 C C id%INST_Number = -1 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) id%LSOL_loc=0 NULLIFY(id%SOL_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%IS1) NULLIFY(id%STEP) 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%PROCNODE) 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) 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_BEFORE_L0_OMP) NULLIFY(id%IPOOL_AFTER_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) 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.1.2/src/mumps_metis.h0000664000175000017500000000236613164366240016242 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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); #endif #endif MUMPS_5.1.2/src/zfac_asm_ELT.F0000664000175000017500000001747113164366265016137 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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) IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) 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(8) :: POSELT 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)) POSELT = PTRAST(STEP(INODE)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS) END IF 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 END DO END IF 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) 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) 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 :: 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)) A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = ZERO NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) 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.1.2/src/cfac_mem_stack_aux.F0000664000175000017500000001535013164366264017435 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, COMPRESSCB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: COMPRESSCB 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. COMPRESSCB ) 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. COMPRESSCB) 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, COMPRESSCB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: COMPRESSCB 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 > 300) DO I = 1, NBROW_STACK IF (COMPRESSCB) 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. COMPRESSCB) 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.1.2/src/zomp_tps_m.F0000664000175000017500000000070113164366266016024 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C SUBROUTINE ZMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE ZMUMPS_TPS_M_RETURN MUMPS_5.1.2/src/dfac_process_blocfacto.F0000664000175000017500000006605713164366263020321 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.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, NBPROCFILS, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, & 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 USE DMUMPS_LOAD USE DMUMPS_LR_STATS USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_DECOMPRESS_PANEL, & DMUMPS_COMPRESS_PANEL, & DMUMPS_BLR_UPDATE_TRAILING, & DMUMPS_FAKE_COMPRESS_CB USE DMUMPS_ANA_LR, ONLY : GET_CUT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), 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 NBPROCFILS( KEEP(28) ), 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), 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) :: LAELL INTEGER(8) :: POSELT INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, LPOS1, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTBL LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION ONE,ALPHA PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO INTEGER :: SEND_LR_INT, NELIM, NPARTSASS_MASTER, & CURRENT_BLR_PANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: SEND_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U 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 INTEGER T1, T2, COUNT_RATE DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL :: DYNAMIC_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE 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, CURRENT_BLR_PANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, SEND_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) IF ( SEND_LR_INT .EQ. 1) THEN SEND_LR = .TRUE. ELSE SEND_LR = .FALSE. ENDIF IF ( SEND_LR ) THEN LAELL = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LAELL = int(NPIV,8) * int(NCOL,8) ENDIF IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LAELL - LRLUS, IERROR) IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN LP=ICNTL(1) WRITE(LP,*) &" FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_PROCESS_BLOCFACTO" ENDIF GOTO 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) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress DMUMPS_PROCESS_BLOCFACTO, LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR( LAELL-LRLUS, IERROR ) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (ICNTL(1).GT.0 .AND. ICNTL(4).GE.1) THEN LP=ICNTL(1) WRITE(LP,*) &" FAILURE IN INTEGER ALLOCATION DURING DMUMPS_PROCESS_BLOCFACTO" ENDIF IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(70) = KEEP8(70) - LAELL KEEP8(68) = min(KEEP8(70), KEEP8(68)) KEEP8(71) = KEEP8(71) - LAELL KEEP8(69) = min(KEEP8(71), KEEP8(69)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LAELL,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 ( SEND_LR ) 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))) ALLOCATE(BEGS_BLR_U(NB_BLR_U+2)) CALL DMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, KEEP(470), & 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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 #if ! defined(NO_XXNBPR) CALL CHECK_EQUAL(NBPROCFILS(STEP(INODE)), & IW(PTRIST(STEP(INODE))+XXNBPR)) DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) #else DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) #endif 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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, & NBPROCFILS, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, 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)) POSELT = PTRAST(STEP(INODE)) LCONT1 = IW( IOLDPS +KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 +KEEP(IXSZ)) 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, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS) ELSE CALL DMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS) 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(IPOS), NCOL1, A(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(IPOS), NCOL1, A(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF (KEEP(486) .GT.0) THEN CALL SYSTEM_CLOCK(T1) ENDIF IF (DYNAMIC_ALLOC) THEN CALL dtrsm('L','L','N','N',NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, A(LPOS2), NCOL1) ELSE CALL dtrsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, A(LPOS2), NCOL1) ENDIF IF (KEEP(486) .GT.0) THEN CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_TRSM_TIME = ACC_TRSM_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (SEND_LR) THEN 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 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) MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) 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)) CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L)) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL & (A, LA, POSELT, IFLAG, IERROR, NCOL1, & BEGS_BLR_L, NB_BLR_L+1, DKEEP(8), KEEP(473), BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP(470), KEEP8 & ) IF (IFLAG.LT.0) GOTO 300 #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_DEMOTING_TIME = ACC_DEMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL SYSTEM_CLOCK(T1) #if defined(BLR_MT) !$OMP END MASTER #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. & ( .NOT. SEND_LR .OR. (NPIV .EQ.0) .OR. & (KEEP(485).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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (SEND_LR) THEN IF (NELIM.GT.0) THEN IF (DYNAMIC_ALLOC) THEN LPOS1 = int(NPIV+1,8) CALL dgemm('N','N', NELIM,NROW1,NPIV, & ALPHA,DYN_BLOCFACTO(LPOS1),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ELSE LPOS1 = POSBLOCFACTO+int(NPIV,8) CALL dgemm('N','N', NELIM,NROW1,NPIV, & ALPHA,A(LPOS1),LD_BLOCFACTO, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, & BLR_L, NB_BLR_L+1, & BLR_U, NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, KEEP(470), & KEEP(481), DKEEP(8), KEEP(477) & ) 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_UPDT_TIME = ACC_UPDT_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) CALL STATS_STORE_BLR_PANEL_MRY(BLR_L, & 0, NPARTSCB, 'V', 2) IF (KEEP(485).NE.0) THEN CALL SYSTEM_CLOCK(T1) CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NCOL1, & .FALSE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L, CURRENT_BLR, 'V', NCOL1, KEEP(470)) CALL SYSTEM_CLOCK(T2,COUNT_RATE) ACC_PROMOTING_TIME = ACC_PROMOTING_TIME + & DBLE(T2-T1)/DBLE(COUNT_RATE) IF (KEEP(201).eq.1) 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) CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF ENDIF ELSE IF (DYNAMIC_ALLOC) THEN LPOS1 = int(NPIV+1,8) CALL dgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,DYN_BLOCFACTO(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) ELSE LPOS1 = POSBLOCFACTO+int(NPIV,8) CALL dgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,A(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(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 (SEND_LR) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, .FALSE.) DEALLOCATE(BLR_U) CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8, .TRUE.) DEALLOCATE(BLR_L) ENDIF ENDIF IF (DYNAMIC_ALLOC) THEN DEALLOCATE(DYN_BLOCFACTO) DEALLOCATE(DYN_PIVINFO) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(70) = KEEP8(70) + LAELL KEEP8(71) = KEEP8(71) + LAELL POSFAC = POSFAC - LAELL CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,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 (SEND_LR) 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 (SEND_LR) THEN IF (KEEP(489) .EQ. 1) THEN CALL DMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NCOL1, & BEGS_BLR_L, NB_BLR_L+1, & BEGS_BLR_U, NB_BLR_U+1, 1, & DKEEP(8), NASS1, NROW1, & KEEP(50), WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, STEP_STATS(INODE), 2, & .TRUE., NPIV1, KEEP(484)) 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, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 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 (SEND_LR) 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 ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_L)) DEALLOCATE(BEGS_BLR_L) 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, K470, & 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, K470 CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(OUT) :: IERR, IFLAG, IERROR 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 :: LRFORM, K, M, N, KSVD 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, & LRFORM, 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 ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & KSVD, 1, & MPI_INTEGER, COMM, IERR ) IF (DIR.EQ.'H') THEN IF (K470.EQ.1) THEN BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M ELSE BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + N ENDIF ELSE BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M ENDIF IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, KSVD, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (LRFORM .NE. BLR_U(I)%LRFORM) THEN WRITE(*,*) "Internal error 2 in ALLOC_LRB", & LRFORM, BLR_U(I)%LRFORM ENDIF 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.1.2/src/cfac_omp_m.F0000664000175000017500000000117613164366266015727 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C C SUBROUTINE CMUMPS_FAC_L0_OMP_RETURN() C C Research work on multithreaded tree parallelism initiated in C the context of the PhD thesis of Wissam Sid-Lakhdar (ENS Lyon) C might impact a future release. C RETURN END SUBROUTINE CMUMPS_FAC_L0_OMP_RETURN MUMPS_5.1.2/libseq/0000775000175000017500000000000013164366240014210 5ustar jylexceljylexcelMUMPS_5.1.2/libseq/elapse.h0000664000175000017500000000154113164366240015633 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/libseq/Makefile0000664000175000017500000000065113164366240015652 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # all: libmpiseq .PHONY: all libmpiseq clean include ../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.1.2/libseq/README0000664000175000017500000000032113164366240015064 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.1.2/libseq/elapse.c0000664000175000017500000000152713164366240015632 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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.1.2/libseq/mpi.f0000664000175000017500000015617313164366240015161 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 C C C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license: C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html C C****************************************************************** C C This file contains dummy MPI/BLACS/ScaLAPACK libraries to allow C linking/running MUMPS on a platform where MPI is not installed. C C****************************************************************** C C MPI C C****************************************************************** SUBROUTINE MPI_BSEND( BUF, COUNT, DATATYPE, DEST, TAG, COMM, & IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, 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, COUNT, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, IERR INTEGER BUF(*) IERR = 0 RETURN END SUBROUTINE MPI_BUFFER_ATTACH C*********************************************************************** SUBROUTINE MPI_BUFFER_DETACH(BUF, COUNT, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, IERR INTEGER BUF(*) IERR = 0 RETURN END SUBROUTINE MPI_BUFFER_DETACH SUBROUTINE MPI_GATHER( SENDBUF, COUNT, & DATATYPE, RECVBUF, RECCOUNT, RECTYPE, & ROOT, COMM, IERR ) IMPLICIT NONE INTEGER COUNT, DATATYPE, RECCOUNT, RECTYPE, ROOT, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) IF ( RECCOUNT .NE. COUNT ) THEN WRITE(*,*) 'ERROR in MPI_GATHER, RECCOUNT != COUNT' STOP ELSE CALL MUMPS_COPY( COUNT, 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, COUNT, & DATATYPE, RECVBUF, RECCOUNT, DISPLS, RECTYPE, & ROOT, COMM, IERR ) IMPLICIT NONE INTEGER COUNT, DATATYPE, RECTYPE, ROOT, COMM, IERR INTEGER RECCOUNT(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 ( RECCOUNT(1) .NE. COUNT ) THEN WRITE(*,*) 'ERROR in MPI_GATHERV, RECCOUNT(1) != COUNT' STOP ELSE CALL MUMPS_COPY( COUNT, 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, COUNT, DATATYPE, & OPERATION, COMM, IERR ) IMPLICIT NONE INTEGER COUNT, DATATYPE, OPERATION, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) CALL MUMPS_COPY( COUNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_ALLREDUCE, DATATYPE=',DATATYPE STOP END IF IERR = 0 RETURN END SUBROUTINE MPI_ALLREDUCE C*********************************************************************** SUBROUTINE MPI_REDUCE( SENDBUF, RECVBUF, COUNT, DATATYPE, OP, & ROOT, COMM, IERR ) IMPLICIT NONE INTEGER COUNT, DATATYPE, OP, ROOT, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) CALL MUMPS_COPY( COUNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_REDUCE, DATATYPE=',DATATYPE STOP END IF IERR = 0 RETURN END SUBROUTINE MPI_REDUCE C*********************************************************************** SUBROUTINE MPI_REDUCE_SCATTER( SENDBUF, RECVBUF, RCVCOUNT, & DATATYPE, OP, COMM, IERR ) IMPLICIT NONE INTEGER RCVCOUNT, DATATYPE, OP, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) CALL MUMPS_COPY( RCVCOUNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_REDUCE_SCATTER, DATATYPE=',DATATYPE STOP END IF 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, RECVCOUNT != SENDCOUNT' 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, COUNT, DATATYPE, ROOT, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, 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, COUNT, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER DATATYPE, COUNT, IERR INTEGER STATUS( MPI_STATUS_SIZE ) WRITE(*,*) 'Error. MPI_GET_COUNT 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, COUNT, DATATYPE, SOURCE, TAG, COMM, & IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, DATATYPE, SOURCE, TAG, COMM, IREQ, IERR INTEGER BUF(*) IERR = 0 RETURN END SUBROUTINE MPI_IRECV C*********************************************************************** SUBROUTINE MPI_ISEND( BUF, COUNT, DATATYPE, DEST, TAG, COMM, & IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, 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, INCOUNT, DATATYPE, OUTBUF, OUTCOUNT, & POSITION, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INCOUNT, DATATYPE, OUTCOUNT, 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( INCOUNT, DATATYPE, COMM, SIZE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INCOUNT, 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, COUNT, DATATYPE, SOURCE, TAG, COMM, & STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, 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, COUNT, DATATYPE, DEST, TAG, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, 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, COUNT, DATATYPE, DEST, TAG, COMM, IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, 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, OUTCOUNT, & DATATYPE, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INSIZE, POSITION, OUTCOUNT, 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( COUNT, ARRAY_OF_REQUESTS, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, IERR INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER ARRAY_OF_REQUESTS( COUNT ) WRITE(*,*) 'Error. MPI_WAITALL should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_WAITALL C*********************************************************************** SUBROUTINE MPI_WAITANY( COUNT, ARRAY_OF_REQUESTS, INDEX, STATUS, & IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, INDEX, IERR INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER ARRAY_OF_REQUESTS( COUNT ) 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( COUNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COUNT, DATATYPE, IERR INTEGER SENDBUF(*), RECVBUF(*) IF ( DATATYPE .EQ. MPI_INTEGER ) THEN CALL MUMPS_COPY_INTEGER( SENDBUF, RECVBUF, COUNT ) ELSEIF ( DATATYPE .EQ. MPI_LOGICAL ) THEN CALL MUMPS_COPY_LOGICAL( SENDBUF, RECVBUF, COUNT ) ELSE IF ( DATATYPE .EQ. MPI_REAL ) THEN CALL MUMPS_COPY_REAL( SENDBUF, RECVBUF, COUNT ) ELSE IF ( DATATYPE .EQ. MPI_DOUBLE_PRECISION .OR. & DATATYPE .EQ. MPI_REAL8 ) THEN CALL MUMPS_COPY_DOUBLE_PRECISION( SENDBUF, RECVBUF, COUNT ) ELSE IF ( DATATYPE .EQ. MPI_COMPLEX ) THEN CALL MUMPS_COPY_COMPLEX( SENDBUF, RECVBUF, COUNT ) ELSE IF ( DATATYPE .EQ. MPI_DOUBLE_COMPLEX ) THEN CALL MUMPS_COPY_DOUBLE_COMPLEX( SENDBUF, RECVBUF, COUNT ) ELSE IF ( DATATYPE .EQ. MPI_2DOUBLE_PRECISION) THEN CALL MUMPS_COPY_2DOUBLE_PRECISION( SENDBUF, RECVBUF, COUNT ) ELSE IF ( DATATYPE .EQ. MPI_2INTEGER) THEN CALL MUMPS_COPY_2INTEGER( SENDBUF, RECVBUF, COUNT ) ELSE IF ( DATATYPE .EQ. MPI_INTEGER8) THEN CALL MUMPS_COPY_INTEGER8( SENDBUF, RECVBUF, COUNT ) 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 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.1.2/libseq/mpic.c0000664000175000017500000000117113164366240015304 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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; } MUMPS_5.1.2/libseq/mpif.h0000664000175000017500000000504713164366240015322 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.1.2, released ! on Mon Oct 2 07:37:01 UTC 2017 ! ! ! Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license: ! http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html ! ! ! Dummy 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_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_BSEND_OVERHEAD=0) DOUBLE PRECISION MPI_WTIME EXTERNAL MPI_WTIME MUMPS_5.1.2/libseq/mpi.h0000664000175000017500000000327613164366240015156 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * * * Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license: * http://www.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 of MUMPS work. * Most of the time, users who need this file have no call to MPI functions in * their own code. Hence it is not worth declaring all MPI functions here. * However if some users come to request some more stub functions of the MPI * standards, we may add them. But it is not worth doing it until then. */ 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); #ifdef __cplusplus } #endif #endif /* MUMPS_MPI_H */ MUMPS_5.1.2/MATLAB/0000775000175000017500000000000013164366240013671 5ustar jylexceljylexcelMUMPS_5.1.2/MATLAB/Makefile0000664000175000017500000000135613164366240015336 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.1.2/MATLAB/sparserhs_example.m0000664000175000017500000000112313164366240017571 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.1.2/MATLAB/mumps_help.m0000664000175000017500000001142513164366240016223 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.1.2/MATLAB/README0000664000175000017500000001131013164366240014545 0ustar jylexceljylexcelREADME ************************************************************************ * This MATLAB 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 * * public domain. Up-to-date copies can be obtained from the Web * * pages http://mumps.enseeiht.fr/ or * * http://graal.ens-lyon.fr/MUMPS * * * * 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. * * * ************************************************************************ ************************************************************************ 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 ****************************************************************************** %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.1.2/MATLAB/make.inc0000664000175000017500000000367113164366240015310 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.1.2 # 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.1.2/MATLAB/mumpsmex.c0000664000175000017500000006471513164366240015725 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,40); 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),40); 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,40); 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.1.2/MATLAB/lhr01.mat0000664000175000017500000074250013164366240015332 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.1.2/MATLAB/initmumps.m0000664000175000017500000000116013164366240016072 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,40)-9998,'CNTL',zeros(1,15)-9998,'PERM_IN',-9999,'COLSCA',-9999,'ROWSCA',-9999,'RHS',-9999,'INFOG',zeros(1,40)-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.1.2/MATLAB/printmumpsstat.m0000664000175000017500000000256113164366240017165 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.1.2/MATLAB/zsimple_example.m0000664000175000017500000000157013164366240017250 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.1.2/MATLAB/dmumps.m0000664000175000017500000000467113164366240015364 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.1.2/MATLAB/multiplerhs_example.m0000664000175000017500000000105213164366240020130 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.1.2/MATLAB/zmumps.m0000664000175000017500000000467113164366240015412 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.1.2/MATLAB/simple_example.m0000664000175000017500000000214113164366240017051 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.1.2/MATLAB/diagainv_example.m0000664000175000017500000000237013164366240017346 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.1.2/MATLAB/schur_example.m0000664000175000017500000000421413164366240016707 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.1.2/VERSION0000664000175000017500000000005013164366235014000 0ustar jylexceljylexcelMUMPS 5.1.2 Mon Oct 2 07:37:01 UTC 2017 MUMPS_5.1.2/examples/0000775000175000017500000000000013164366240014547 5ustar jylexceljylexcelMUMPS_5.1.2/examples/Makefile0000664000175000017500000000440413164366240016211 0ustar jylexceljylexcel# # This file is part of MUMPS 5.1.2, released # on Mon Oct 2 07:37:01 UTC 2017 # topdir = .. libdir = $(topdir)/lib default: d .PHONY: default all s d c z multi clean .SECONDEXPANSION: all: c z s d multi c: csimpletest z: zsimpletest s: ssimpletest d: dsimpletest 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) .SUFFIXES: .c .F .o .F.o: $(FC) $(OPTF) $(INCS) -I. -I$(topdir)/include -c $*.F $(OUTF)$*.o .c.o: $(CC) $(OPTC) $(INCS) $(CDEFS) -I. -I$(topdir)/include -I$(topdir)/src -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 MUMPS_5.1.2/examples/README0000664000175000017500000000274113164366240015433 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). MUMPS_5.1.2/examples/ssimpletest.F0000664000175000017500000000472213164366240017237 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 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.1.2/examples/input_simpletest_real0000664000175000017500000000027513164366240021111 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.1.2/examples/multiple_arithmetics_example.F0000664000175000017500000000753013164366240022625 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 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.1.2/examples/zsimpletest.F0000664000175000017500000000472213164366240017246 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 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.1.2/examples/csimpletest.F0000664000175000017500000000472213164366240017217 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 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.1.2/examples/c_example.c0000664000175000017500000000444213164366240016654 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.1.2, released * on Mon Oct 2 07:37:01 UTC 2017 * */ /* 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 inside * their runtime library while a Fortran program translates * to MAIN_ or MAIN__ which is then called from "main". This * is annoying because MAIN__ has no arguments and we must * define argc/argv arbitrarily !! */ 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]; MUMPS_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.1.2/examples/input_simpletest_cmplx0000664000175000017500000000050213164366240021302 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.1.2/examples/dsimpletest.F0000664000175000017500000000472213164366240017220 0ustar jylexceljylexcelC C This file is part of MUMPS 5.1.2, released C on Mon Oct 2 07:37:01 UTC 2017 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.1.2/LICENSE0000664000175000017500000000424513164366235013747 0ustar jylexceljylexcel Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, University of Bordeaux. This version of MUMPS is provided to you free of charge. It is released under the CeCILL-C license, http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html, except for the external and optional ordering PORD, in separate directory PORD, which is public domain (see PORD/README). 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 of Matrix Analysis and Applications, Vol 23, No 1, pp 15-41 (2001). [2] P. R. Amestoy, A. Guermouche, J.-Y. L'Excellent and S. Pralet, Hybrid scheduling for the parallel solution of linear systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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.1.2/doc/0000775000175000017500000000000013164366240013476 5ustar jylexceljylexcelMUMPS_5.1.2/doc/userguide_5.1.2.pdf0000664000175000017500000262030113164366240016714 0ustar jylexceljylexcel%PDF-1.5 %ÐÔÅØ 2 0 obj << /Type /ObjStm /N 100 /First 814 /Length 1582 /Filter /FlateDecode >> stream xÚV]oÛ8|÷¯ØLj‘ÔgÑ+¦×CÜIz‡üBÛtLT JJ.ýõ7+ÉŽÝ‹#_¦”)q¸³3Ü¥ €"RÅF”Q‘HHEÿ¢”DH"ÁLB2À»”¤ÄŸ «”$3ü€R˜!•à³ŒB| È0 ð‚ CH–PãWJ1ÀBAq BIqñö‰ÂS’&XD©Ä×¥±¢HQ`)`”P–`@pÀb1’ƒXbÌ2Š¦PcŒÀ‰3Œ ¨1/D†¥BF’0“ø1 à=ð‚L§â`O¥ˆx!X¥À ±S€•ˆ ’Æ(£,ä„ax1öAfDÌ/&2ˆˆ ø Îd’qª™*&Д#ãì§YCD†, V ‹“Àr#X…@ÄL‡U‘ÁJ‰`b'À7PCŠˆ©fxà˜%¥`RÐJ†Ì6ħ ºHV|I*L h#U ÀœdÈAq˜PHFœtäVF ìÀì~¥dÃZIpo¬$fŠ×2I l,S‚É4å gœH&³0jœ‡¸Ø‚ ŽØ‚©€#LØc¬!tƒ|œHA Ê DP3°œ` ¤M8µxàô²)[Qª0à9„Žª0ã G*ædã!ƒ·oéì–Î>»;Ggè¨4ÓʺâTÓ»wƒ£/EåݬnæŽ÷~,Û¿ºÊ”4wžêÒø’ÜœVÞ«}§^å¼ý¡àŸ¶hç…f‰‚5Ý4½ž…Ù:åK” ©îòÞï8´ ï@ýÑùïðö£Î~Î÷tv]ν1ë€û–ÉÒ[ð®ht\ÖyöÞè4@ýA·BVË>!Dwx®êjèæéóf}pžú–v†ý—z–¯è;ÛbǨ~ÙtFD [ú®ÈœENçÀƒ ’9›ºbÆe NFþ'¹YrËÖEÓfÛ4>º.jßÜOòæP7Yó Àlƒ0û¹fûBéœü>wÓïtééFß±ßûË›ñq+ ÚuÛC¯¥;Ðõ7¹-‘~Ð6× HÞqþ^¬lJ—êóÕ*‡³›“uínKÚtæW¹m®ŸMš˜÷UAî ›ª²‹¶Ñ2=¡ó®žÐ§íœ—sBw­š ÇG\½ß—öÝݺÃðg{tPÅ–ãY¨Ö6Ü4Ö­ƒ.®F£º>¿é‘ë®ÃmnÔ”Õþ6wìvUO«Æ¡á½¹r^ïªL r¯íšÍ¥–Ok³ë²4KØi¶îãõÅ#ÿ4ž[_RžŸöoÔ…÷MÏÛI]ýÂFâDž¨ƒ6ë¤üØj²—62ùoª;ø¿ÐYÖ­În_ipïÖ4·yßQR/ÜjÞÐ ¾_7l ý0ÞµÝ`fõ=_¼Ú SÓ’þûüï# endstream endobj 203 0 obj << /Type /ObjStm /N 100 /First 871 /Length 1580 /Filter /FlateDecode >> stream xÚ¥VÛNÜH}Ÿ¯¨G ¸o¾DI$B²«Hä"H´/¼4ž°â±gÛ6„|ýžòe.„ÁF+%rOÓuªNÕéê’¤€d’æOD‰")Š¿‚D$ñÕퟤ0$5c’1R:!)%©8™I©Hkß@‹B|#2_1ØW‚L ¥)”p§ …†¿1…í~B‘ž–%z&µ¢XÂN‡›¨õ'𠛘IŒ8& i ŸˆIpB„à€ÿBj&C……†·0Ä"FxaÄt1ïVˆë@6G@6ˆC]&9”œ ‡!ÂE("â8*¢¤K’ˆÙ{ä$€‹È ŸI€œð™Äpr‘þ ±H8µ)Ô¹ gŠ-ù  8›*Ä"â´aµB¾°Ã–¼ÓÖÀP\.#5œà Ψ(ÉÁL¡dÈË68#™[T ü@ŽØŠs¼rŒ¿+Å$CÞI˜$kf«â™ÒÌ6ÆÍá ^DX°•an!/H›jƒC˜Ê0%øQ-“*PÈ£’Ù@×J¡‚ˆ¨ ÂßHñ®bdTPiÁ;ÀÒì hÞŽØ R«"F‡ì*¨L$fª uP¨ ÜÀT!ꥸ!.‡JªV¨ @aÊ…‰b€µ–¶âìs~4»‰C1{ó†N.éäïò{I'è j®ùŸKë¬,^™Wê•8¤wïfßœ_6µåmªK²ôÛùòxá£yfoÊÂætuðéìË÷ó«ƒðêðêðp¸ìÀ/S›gÅÍ•žú_ñ~¸5–îÃônåËÔUð^Sõ°\ºÚg)­6ñWã‘éöåSt‡ƒon„pm1â•É4þzàÿwvç ž;¿“à¾;È1ïŒ&ÃôÉ(«úx;Yí<Ü9òn‘néŠz*Üå¼G,ÊþPeÕHÔ|mêãrqœ–Þm8J9¡ºqðOéV+›:ZYoQç« ’ÐÊ ¹Ýi*çé~°q–tξ4yN«ì®¬É—÷4‡·öĈµ:óY•Z?§¥…|~Ѳd¶¢UboÑËð¬\®ñ• ªo]_f…-ê-P5´WÝ_¥¿ç]ž1N >oZvÑf¿»Í ü”Z ÕÁ_d7·õñ-§¿Êæ®­CUæÍÖ ªNÚì@Tã—E¬[ÑWTPð#ø Ü‘`Êý›=bŠ#y¤&âö98e¡ÖYÚäÖSjáÕ«žtöšÒ¶Èœ~\KŸ¹ŠŸ‹­üÏ]ÿG!ôñŒÁÐ^»­ôoˆ‰$ˬ•ð®›z?âx‹zhý·o©çm;¢û¬¾E{š7)àKþS1ç‚Ï÷WG$.þÄ÷G¬Ûüv’þˆ¨‚R±ýÀ} Úu;±ëN¿»?í"Kf¯&«ñHQµeQý‡}ù~ðkЉÀnÛè{ÉZ"«[¾¡ Jo)8"Á~å¸bzù½ÏËô'£%_Øâ'ðÞŸ_ þûZ–éµ±~Q'4ƒ2>öºM¸çÂ-š¢=…,×dkÊŠª¶yn÷¿ {)œ®Vy–vá~óå 4úT ©/ö>Q€ú¢sTeS£w`àáG¢BÇyª£ö¶áð¦@+e¾õ”>[€pÈÇxãÚ‹ù2ûž÷…³ùI'Ë_/Q›L¯³¶ ×®¾w> stream xÚuUM“Ü&½Ï¯à©*b¹eSÙToÅñŽ+ÇFbfT+‰1HvòïÓ´3³kŸÔÐM÷ë×"èˆúmC¾ó½Ûm¶÷¥BTbFG»ˆ5Vœ¡Š—˜Õ5Úµècö𡟺ƒ³ã¤û¼`‚dÚû.g"û’S‘™þ¿xý.œ´Ó}o’á£í£‰Ë?íÞ É1— ŒbE“÷ˆ A¹½çäŠÀ²,g‚ððî1º˜b¼ÀN$ªZŸ€_º-”•â·Q?xãüÑãqîZ=2(X Á‚GE±T@f\®NIy‰}±,jŽ…”¨QEã?›Éî!ó%û1} •Áëj@þ ûUµdÀ*… .pÍTtøóÞON7ÓwÞ¤Ëû‚@RÐ ó2e½;u`@áZÛ̃§t2¾qÝÞ$åt2AàÙ}¨utŒ%âWm~‰ŸÙ/y‚Ô“q‡œ’L7Ïþìs¯d5®Øu…ok{±%âÙçEIXöw^“Ì<'ÓlÉa…±*&Ýõ±˜.ë@ Â%Nc®à©Õ“Ž<7ÓìŒ5«ev†ž äµ^4ÐâÝxLææólÆ&Y׉›€Í9X‘*k;}­ŸºÆzNHv§}×$»Àò¿z8÷ ÊÙÙ#Dôñ4ûê5ä6‘8"¯¹c SNWî´3±uïm” Zð† Å‘)*`bè­ÿûÎù)`/³nXß,³úÈG[r9æa ´”$½ ëâkôo ^ ì;Æ‹°îzÛ<o£q¼~/€YÎiØäPù»·ï—é^ôë€-ÙaLb6%æâ63èC'w½Þ÷‰”¥k%ó¾_ª²3½Ñ~ie8ÙCÚ€m|3ˆ¿î6Ÿ7hXc°Œ.y…Â7Ãæã'‚ZнA fþºX°Á&2¬­=nþJ[™ÁþS®Ãbä%ˆ5\ñò‹H‚)¡Á”ã’Âb¸¦Éð÷1´Ð¼d¾§•äp˜R/Ø=ŒK2˜Ï0¦‡Æž»+Ön¼D¦0£µ¼Ýׯñ1H°ÕªÑ)ÔÞ\‡_cÂ/gHðNÉ Îü>UIMª@¤ý ­Ò›—ð(Ç•äkäÓ4Ún‡y8û"/*–yøS‡­;n¿¹^oÖ¬‚ébKm [¬a¹`ÅxôN_öÅÿDàg endstream endobj 469 0 obj << /Length 2209 /Filter /FlateDecode >> stream xÚí\[oÛ8~ï¯ð£ T^DŠZ`’L§ÛA܉»‹ÅÌ>(6#K%·“ýõ{(R²,*‰/ 2iüÐX’EŠúÎáw®.Ü Ðàã;d?O'ï~ú5 ø4àd0™0a>atÀó1ŃÉlðûð,ÏJ™•Åè¿“ß`0ò1üc¥g©O.?š¹„qè©ÐÀ#È'42“à‘‡BÃOY©FX óÙjZ&yf'5+ÐùVCØ#xævG~D¸Dìs>ç¥,Fah86Ì•9YRÙëùÜ|.«ÉfÃoI¾²ß~a4„{aëûaAðš¨õš˜Ãj0«×<þ:¾¸Úx§,#ŸŠæ~þ(¨àz´GYè ^^œ ûÊ~.¬ðì6Înäy~³‰êïÜ;ôGÃÔ|»~ì;îe‡?6®ƒŽ†WÐ>d¥ÕR V §I«;£3Ó|±ŒËä:I“ò®û<Ò#òkäÅÞÈS‹ü×åŠgIvcÀ¿–åw)3s²H²š”Le\È¢» †G\Û¸ý¸ÎU¾è¡B|!:Lèqàbæƒ!06ØŒc¸ÑÞ_æ=SF>ÁagF½°NfÆÍnNM} ühG¾´4’ Ü€QŽp*Ú'¨¦ýÚJY}O²¢ŒÓ4®Œ¬¹R+Wé)á/®µûbm¯\zÞ‰ö¾i·@yà]'e oYy 7Ò’Ê\ÆåJI‡Sàž·…«vû8!]tÙÓp h=òQ™p?Œ¢GÙD<ÄO÷²Ià ²›¼D;ˆv°†FÀ5—j®ÝÞxj5þ{RÞš£òÖ^Ë2±Tg3sp¡wB¬Z_åj&Ùµ±ì%öÃAÈ!2²dWg_FNÎþÙÅm2ŠÈÐë~/xŒ‡¯ Ztöyrþì{Œà/þÇÈ£V¨Å.¿*ùB$“ ˆ6† WN ‡À8pâœR©Úµ³8½+Gs¢\ÛS±Æ”u1%m-–±*j½LnnKï¶Ù¶E2sý("èkˆº(€"F¨&ï´PÔ©#•§›ù–†S¹f€´›“K; õ†Tü°H†Éód*³Âõ$ücå^øN:ΣBbsˆÌƒÚâ8Nlè4_eU¶2N“2‘æñ)[Ƭ›©Ap3Qи°Í+mŸ$pn*m’ƒŸ²åÊ/‹¸TÉ_öÕr§Î>‹ð15ÕR/¼ç¾¦MVðBɥʧ²(úhmwó|”Áö2¨óƒyQz-)Øò@å¾'vk;™óWÁ‰Ï7Ýï¾€@_–»»û!æo΄Ñýõ» H?ô„›1gQ‚(Š2™:ªÎqô¶qõú¹Î‚^¥ÖK]Z]†˜4·&u&KÙSÐM&GoK#Ø[Ëë âY¾O¦•Ø®ƒ†Øjxž®îýrV‘Î4ÑœãøBÍ&é ÊÉCXX'z®ãž8"ó§Vßýã°«<ýÖ˜»&ú*Uœ˼51Ü¥\8åŽÞŽÅÛêÐBý«¶o¹ú^ùÊ"+Ód‘d-…­T×ý(s•ü/î%&Þ®¢ÆUX\OTRÞ.$˜­¦;ƒ5ÝŽ3-ŽŒû$Z5–o!U2ûÌ_O4mãH¼!°½€L ˆOjÒ®ˆ%W6ôq !M2«âpÿº~o.v9rl _|òæJJ‡o ‰ÂcÐþ‚ Fàî]'Y£ð —Ž³¶X¥%X%ãYíË,c§)ØÝÂqh8ï>¾?|ÔÀ÷eUzùÜ›æJ:ù§#M~ÔÞ§?0ðÿq¡ÒÞŸ›ãà„›2Ÿ_¬¡ˆ)ªŸš/ TN^Ÿáv^ŸÂSÖý%'¶… ˜…!¯ºDüÀeEöÙhÚF"Z·1?d¼Iò?Ôv¢[…um¢5ç«ËÈ<&[4ÄáöpŒú„ºnD|)g«©üišg³ª€æ!ª>À;ºN!¼­Nª8L„`BÌyÒiã€Kº’y5½])sªûxS“©4³VÆTõÌYóЙ~™ÞŒh_Y—J÷*½¼Ù:_x`2&¨tå4ͧAœç:œùnN.ãÌ^Öpz~Y‰hígÌUž•u ôhìaô·FSìY5ÅÔü ¡U4 lÑôkQwDš]ÕäËÅm!Ž’4†]iËÕÏB4E÷4WP‰!ŽûEÚ\³k:ÑO\.Sa×I˜ óÀ/Ì…OÍz»OçXDCBv«ÇÖµÔ5ÅØ2“à¢:úBñPmzCŠUº4¿î‚LÊ$Ní†~oTãÄÖRìi•åkï{{]'Z«@ÑžOF¡îÎÚLþi^éi þµTP;¿}9íirÅüúÆ é³4<¤Aæ0háõ8x,Ô·.Oýk„1®ãh›Z_\K7e„oÛΑ}‹íºù²·ûª?¤ë\H£kg_Æã÷¦]úâä²G5áëîê>Õý[Kó09xX6¢®8ˆÛ~36%§né¨îï:²ý£R c{Ò°ý¸Uý+ï–òÁ-r¡Fůþ3Þ¡9~µñÛ¤¶µØ¼D„›Õ -7Ò#·þ6ŽØ1bÚm¯ŸGÔÝ+f·PCÑyíÕy“¸(ä<ø™[K¿Ï¬€`!®7HÓ5Ìê­Ò5+ÔGëýô3ZÇ=.÷£Ð™‹û¦Ö«5µ¾Íw£qt°l{¿ˆÃÊ¢¨Zb¡ý%)»k]S[•‡ÀúbÏ/Þ߆.ÆïÉ{êb܆…+ßVæ Ú«±ÔÂúÁ$mê€}Q°z­7|Fôúµ3Ø5zÕy‡Ì ¬÷ÕÚïü·JJ·ß$éï?.óVÝ“º½ï‚¼v½Z_ =¡“*7Œ+d(¨ÍêÿÒ¢=òÃäÝÿW endstream endobj 526 0 obj << /Length 2416 /Filter /FlateDecode >> stream xÚí\Ks›HÝçWh)UEí~?¦* Ç“¤2•LR¶§¾ÅÌ·ÀÛT$КÄùõÓ 4B Ùc[É"HµÎ¹÷ÜG_G7#8z÷V¯ ý‡óFyrþîÅëË'o‰I 8§£Ëë"HF\2€]ÎFŽ “)‚ Ž?'Á2‰ý MÃèæ—É” 8^Éb•yYG“)Öeqñú=HâéuÅé,ônâÈ›g^4+Rß›ë›Mþù[µâÑŸSBÈL¦ Ñâ¥~6øeë?o|-¢±¬½½¿†€c<ÒàÅT…@/ 5^Û°ñz@ô—FÜ,ää-…›qýePé•ä_÷þì÷ËæR®ÿBÅõ5J)T——mþh)äþwmØò)†(*]бýÂZTˆC‰`È–åÕqÒrCBÎýd'²‹ÆÑbÿ÷é7HDB*šÒ™Iï‹ KB¿àuCuÒæb(æÅC!Ù(:Lˆh%D[Ñ+Þøg‚Ø8ð3mÛÚ£ —pìعèò›Ê-Œæ·ÜSGéº"VÛî)E¾#‰¼oy"ýå‰a€™ËD©Nï fo ~œÌ‚d—bI  bý‘¯)Ì+´Žºî­1J¸â…e/^¡6°Bÿ‰óÊQÚ¤‹•B§ÙÔ‘¢0 í;k p“à/q,‚(sL’«‡“–ÇP¦ÞÃ&¶¼Û IJ òt&t—†Ž¼«Ny?€ÙP€e °°ZeÓøzêÇIÐ I€ÚÜï-À\©ç€û½æ>¼îƒ8`:â5üBZÚþ7‘&$|I—žo‰[z‰§Ãw¤ÝÑŠÍT¿bÑ-L25ðý¢3é2ŽzµQ¯÷Vi`ýûëmüШ‚±€ ÐÉD•%ã÷ÕÜVcK«÷X¯9³‚›·¾ÚÚMóãç U3ø iÑcH™Ú;V ¨o¬Áý5L}/±´ðt"û­8¾66䙼u—khN w옠þvÜìP@þlÙ:Œ¦)bæ$¹lÅ‹e­ºˆ¯m÷ã6X;K²#/ÊvÔF¡ˆKÙ;6!ˆÄ#¥ : –– @]e5ÙÀoMŠ'¹ÚV>ÌCÿš¢Ùj]¬*ü¾qÉ6Ž„.x[™¼·k1FÁ§Zi@"‰¶U┈4œ‡7·ÙôvÝ÷ gA³ÏWm%yz’KžN”Ý*‹<»p@ñaM ”·W….¥ ¢´¬½¶¢»ÍjJ7±½¬öl³[!Ñ3zÚ¿"@BUª=´–€åÆuºheUrÖÆüK¦ý•h<(\T±£Í®0P²%õµªv‹BÏ¡2}µ ½mVBU›XÐÂdÏŒMyóð{Ðð¶¦îE]•@‡(5BÏ'3§lPf.iá€Ù˜¦Ú¯¯L»ÊòÀÆj ;ÚÄ’¢§éP­< èñ 0wz<ˆÉà…»Ò‚ͤÈew^ôŒõ¹ ³Ûâ“$˜­|C‘y;NŠW?Žf&í™Ùk6Ý|\Ä\óÉ6mÔÙ:%®:¢mÛ-Œ.Ew“H× 4ÊÁµ}ð½ëÎèq ìC¤ÓýÒîØd™O;úlÍÔnši.º.)/»º«õÃvtb”BñþØ'<+)ïÍÉôõÒLåëŠ;ĶÔŽ]W‰"¶^\î2¯­³Dìzý¡F Ld Ôä~l××!pu›.Ö5£ÎX”±= ¶BØ¿i‡u-GT›µÚôì´êåUE9‡´¥´Ù1ª'Ë[/í®ü0€¶UßýbÅ«âæðeñŠê¸âö'Þ P6`Ip@©«§¬ˆñ¯ç±ÿ¥Xч͂s/ú²çõ‡óõ&ÉÀÆ×ù6ru°âŽÚÞ’9Ø5/€rÛæc˜ ­`£Ac„sì2x½‰¼«õØWÕiÖøZlWQ¾=£5"³>ïY=£4óæs¯m÷Faò´ê±þ˜9Ã,˜N—Ëyèo˜Øç$¾I¼Eqò>Ê‚ÄÚ¢³1§ :Ž[†÷ß–beØ©Ì+^eËUVΪ™Í4 }§aËÊ8ûl‰³¾Ý.­k¸VMP…éû* 0/@ϧFŒŽÅ:ÎO.ˆæÎÞ¸³A§ôÚXÙ¿Øþí h@YÝsx>F­g˜¶üMP¥z9»—BÉZž0º§—ñ|b΀~xó“"‡3Ø„¼àüˆÑåjotË‘~³Y«Õê*\ÇÅ« ûTÉËÖ[…åñ¯@{*X)"&¬€½®M2'‹ð»Ý~±‚9XÄĆˆ]׿]'ªe®_>Ÿxþ­]Z1¡W ½×š3X%çûN6ŠJ°€=ÓøÇÐî…s¦ÚÜ´ú¸š1*±N{ŽC=CxÙý¹”´.õ&)2‚dýM·¦_)¤½Iîð¦œZóE¬ø"U&š)û¬R££°õÅÇ?>~¾°Wmþ¬t¹]MZ^«¶I÷™ëù\Á±ÄÃ<ÊÀ²Qå«Ê÷O“Ä»+«žYÛHøgÏu‡Ë}5B­5"MWAZŽëÚ³lH• \U°g);Ï“%^Tµ·«È”smÂ!á‘"Y&0ïO>9~Oå1ïÛ>-bʧ¸ÎWQ.¬ÏëÄË šzCÉOø]øéž]U=»²Y«R8~Yjó®SZͼÌËî–¥<…Ñn!jæ† ¬•U—­\¯‚hÝ/Æô’´¥wøSYâ G˜Ï‡çüš¼ºaŸO'Š/?œ¾>ùägž}\ –k…y—Ók›ªÄ\m¬³o–˜?›tô›g*­Ï>¯Ê-‘r–ªþtŸ.Ï„“>V‹jæ‘B'´º^ò9"aXŸ4&uv~û´¬KÒ4XèjeVU'údáî½òÜ ùž¢¢Çuăb›Ò›w"nŒì§’hàåþÀ“ðyøËý¶î¶þÖ’A Ì¡[óÕœ­YóuÔ{ä¨Úÿª¹“ZJ™†G«&Çùä'ч”› "€¤ýÿFê©ç›Ëÿì“] endstream endobj 404 0 obj << /Type /ObjStm /N 100 /First 920 /Length 2845 /Filter /FlateDecode >> stream xÚÅ[Q· ~¿_¡Ç䡳")RRap¸ Ðm?8Î!1šøŒó¹Hÿ}¿oV{͹ñ­žÒ‡»íÎ|ó ER¤È-ÙRN%{2Ã!’”†cO–%ÉÉ Ž¹&k‘J໎ë¤&É÷IK"VpÒ“h´‹¢¸¾¨$ñ‚›T“ïVKÒ”'%I¯¸]=©ˆã$’ªó¤&µÞqÒ’z²ö` [NÚLS1IÚ+‰òK¦dP±Bb†rŽE²¨àm|áIKÖoÁ¯%¹ ß›ïj'uå ® ¾6©´Ì°ìü‡wóÜxR“+ß Ž‡á¤'w"{N—äµã9µ$ïxÀ§È•'–RÀIIa”¥ñ“Häì5E ’j)z ÷T3PKäT¥óDR5ã,iªûíxIÜÄ7(©ÖUüBú-;ùNH ¼›˜_8&¥ís¶Êiªø¤ O"õ̯ ý®”3$Ûò«=õBi´œ ]|½Þ½iêÒhFµ¡ 4 %[$E ‘¼«X£zEæ­Ð¯\ɳAÁrã{‚¬à¼(F"‚:”z¨K‡¶I©º+ªH@U1]8«†ïísÙñ\Íûd⹺K°ã¹º‹°ã¹Jâ¥ïŠ µt¼®h…Ž;LC´ ð2žfsá°#€9ÐÅ(ÇÆA~4, åža5x†gX7Ç›Âf Ä.´©zñèQ:Á‡¯þõæ2¾|ñÝåÅᳫ×7—¯oÞÂX¯¼8<½|{õîúååÛÝ~÷þ|ùí«Ÿ^ý”¾Îø ŠÒõù ®q/¬!Ž×=~ýú P_ï}~qç‘û÷‡O¯®¿½¼Þ±òóÃ_>ÃÂyΧ¿¼!í¶Iác6囪oxQ(ÑVW={÷Í zõú‡Çíø‡Ç/o^]½><;üåéüûèû››7¿?~|÷ã›·¿{{õÃ?/¯·«ëïƒÕ ösýõo‡Æm´¥ 7ôúÝ?<ÿÐuPÈýÂè¾e¨Ì‹Ÿ@¨‰Sñd÷2¦€úÙ0—"vú#e è«äø(ྼ¾zùìBÁ”}þ$¾ºüéæ}Á¾?—0Ÿ÷ç2~õ\Ê~çî´Ç~Ž1ŽOž<x6ðlàÙÀ³gÏž <x6ðÊÀ+¯ ¼2ðÊÀ+¯ ¼2ðÊÀ+Ïž¼:î÷ë×OŸ\¸>p}àúÀ7^ ¼xá÷ØÔ°ˆ´›Ä/›˜ìƒ“‰ÁOmÊõ!lƒ[†SÝ Œ¢ê–#pÙãôž3ùèíån`›|œþc@Ä¢( k®ØF)œã{Yè²°ºU¸¬0Ùàó4ãá\1‹lpû¿ÌâÝ7·DT '*šñlD,V¶ŠEKã&qžÊ ©äq(¢(¸:x–xå,ç¹ØÃsñŽ…îÖJÝX(´èy.å¹8LNË8À)i­‘†Í>Hå›U™Ÿ ðÁgë-p,“„(Ž‡o†ÕÃÜábHãðó“å „ãþ !|ä zƒèELÉÆ—LV± ‹!¦q†8nVžIBº€) ò7 c…u8dÏ“|l•¹€6Ke .›Û$ŸÖ.˜(eæåîLÝ0®2IhF#ÅØ<è ±Je¦š­“„b¡¼!ÆR;d*WÓ3V>¦@²º!¶£Å>l˜8¹7¦X°b!ìÛV*C ¦°aœ)lELφIA•ƒûŽ™’óT, â·†,Xa 3炱OpYài˜@A:¸ ÎQnå(ðŒ!ÙÏÓ‰‚àÖ¨¹u³f̨¶n6IhÅl! îÜkƒ•X0®åül•‡çb]¶ÎÍ2ið¿uç–ÅÏsñ\Œ:·¤Í¡+·ìqžK,ào— phsã¦%ƽçRpAÕóQ_é«Q>6áôÚ.·~µoLL&„ÒÁQ¸'æ˜Áè„Ç“¼€‹¶-s‡AÖ®,†Ô!t‚Ì‚eÉ!§—÷vMPf› ³ÀÕYFð€|[™ow’CÞP&\,ˆ@ä˜y#(— e8ø6áëdãÕ†Œ¾ÂÙ!­¬Br0“:3M <¯Vd  lRG hÒ¢ 8!3€Uƒ2ƒÜc.'Á”Î@ Íì ö Æg4fAN÷oζÔwz›{#ð²€£Šˆç[Cô¢Â±ÞKc…ÊfªÅq§•¤ðÿ¬[Y²õ ++˶Âé`Iu«m&‘›%|˜yÃb„ô„E0ø—¦:ÉgÁNˆrq¬CÈàu¥b6IhÁ2 "û2ÐXlŒ‚ðÊÏ+Ï áÛ9¨ûÆJ‡8VSÂÑ%Úà rÑáð¤ 7iu’ÐCJf•Ù½ zÌâ° TÖj‘Ÿè/‡œo^\¿øîúÅ›ï\T<'6•D–ÔlˈđßrŠÍ ÙÀ²Ê”[Y¾V9¦Ø,Hü²’¬û–§WgéW\&燣͑~(#_K5gçEä;Õá;Eä;åevuTýï"òá Û$ªý/e×x¿¢ìÇú(ǨˆÖQ!­§ñ¨ÖQ!­£BÚF…´ iÒ6*¤mTHÛÀk¯ ¼6ðÚÀë¯ñüTî·Ü~ÄõSeºü>ðûÀï¿qØòq<ü¬ãhã8pGCn ?ö[ì-ÇãÀ“7¦ÚÇüûèð¡>&ÜeàʽʽʽʽëéýõA+˧º!†½V‡õ½CÔÑu¦V·¤šÈX«³@ÖÍ>)ä sÅ:_³ÇÈX¬3e­„°ZÌë|Í_ qØ‹uYý°ßgŠuKj-am/ÖÁƒ!yaw@›¬ÖùšÒjh=Vë*…B‚u²ZçkJ«!ÈÁåhZXOï«ÖÝ’ñí~,ÔAƒ;eÅI³óTbEwen±AwµP+÷Öèn¹,ØuD\¾·‹"qe÷æ½å¹[. ö@½êY ê86pÓ{Ks·\úŠ¦ª¬³—Ù¦g‹>“/ØuÏ[ŒÍd«AnÙmÂç­Øu$0UÙ¡`pÄìÀ¸Æ™­ÚX¦Üs`z`‡GnR'ȬhŠ‡c–z²θy›ËÇ—,ÞØŽ›lX—‚(\[Ÿå£+*ïÜÐÛÝP’pÉu–‘-¨½7g|OŒlœ=ðð̽éÿƒÑIFµ0À‚FÃsd¤6KhAShçÁm&¬ÝÈ4¡1 œeä+Z”åË[5*ØtfŸIìÚ–" ±øC¸E’vˆþÆdNsÅj“í}ûDÙ[¼É¬•5= ö 4Ó¸¢ˆx´ÍZáƒØ‰I&\Së±>¯Ñg-°xcCfÛ\˜ÙxE“YB+ZMlOk¢²]Ä|"$”ícÆfLÖ:pðOúÃ%e ‹Ââ&C${Û˜+³Œ¨4E³ÿÄŒ=[œ/xìR}–Ñ‚e•!إœK€Ü“T .+zMT7g«Ÿ³9‚2ŒûÙ<+¶%Ýð€Œ4ø[!áúÎÅKÏsYÒ<ÀƺrL……½¢ô…vžËUaѵ±L¹1zþ`³ßà± fgBö½“¿fÀ$Õóûu…¢(¬ºrŸ¢÷­Eá¯C·fç©èŠÂxÛ:÷)G8»Gô¸¿0~»-ðo?QÐ} endstream endobj 535 0 obj << /Length 164 /Filter /FlateDecode >> stream xÚ=‚0†÷þŠaèÑëÇÙ®!1N¦›q0,àÿʼnƒ‰Ãår÷~<   jÛ )ƒq~¬Ç¥û(ªÚjð˜-ÄH;ÔÎ{‡db ׂt)RÅy¸wÏ©+oñ´•ƒaFK»t|¼ùäš0h^&3cI¾èÚá5ýÇÉrU›©Žç¾>U{BM ’Iç€ýò£x¶\>V endstream endobj 569 0 obj << /Length 3636 /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®~¹ûL- KãXáøh±2¥‘ï?¾ÿñ‘AWO& 3Zµ£ú9ÒÑÏBÈ÷‹6ß×UÙfÅj-`¥÷YÓä+¡—¿­¸^Ú≺ÄVVgEa=ᇪ ’&R0!§þ¼¡ÿŒþNÙö!»·ÔØW5=408/ï}ã©iíÑ K—Õž:‹¼´™§¶¿ž3ܽŸH`°mÚHŠ¥Úo¿=àRÒ-u$1I/)X¬ƒÞ|òCyò˜ñžä¯3s¤,&lfd­™I;Q ü¨hùx°µ™ 6¡àÔG3³Áö¸L…¯$ñÊdÙ€hj¿åæ”Õ>fm"šöµÔ»ÍJzØXzesXM}ç²y:-ŒÛzž»6œª&oºA§À#É¢HagŽ"Qæ­…©¤€c…E$—Ë{[Úu Ãõ¤€ƒ-©—7лY‰hyníŽ:öXÕOô¼­Ž'xS7læB¥çiØÕ Çu§”O…=Ú²mh…,pRÛmhÕΫ^"™r¼éMÖ ³BGn'øŸÑßñ<ºføâtª«l{ Öã!'[£ê6£ñÏÎp+3?é~ÅáͶ­êü÷¬· #µâ ؃§’2%’‘vÕ=b:Ž_R÷NýÞ}DŠÎžMU5»¦ùÐÊpg†ck+–ŠtÌÜÕ ¢˜î/È»™“„§4ÝÔ þêë£Óqh‚Zeåý¹p–%ý5ÁånN¦`²ûªÌV|YPGwp@÷†u0¢! çÜ ¯ªwN7à‘‡¢¾YÒ¿?Én±‚º7ÞXØè’”zù––ÞÕvÖÀYœ¶HÅb8ÂÑQ×6#fÀ³¶9aZÖyoX»ݟ¼¼Qj5 þ’ÿi™ŽÞ5Z7n.¹¼qanÞÈ’¼•%Ý8@ò[Y·žÃ­Râ·îYßzÐúÖneIÞ*Ô›9JnêͪßÊ’šøeÈ÷碠»¿³m–3ÑØTùŠzÿÒÚí¡Ì=[W΀¾öÈ¥¸¯Ó:$SzhTÛ"km×håoÇ-¸dj$ïÂR$ÌXr%™”ê @úä9Ho.08òB ¿›¼ ò©­gû˜…N`ÿÔüyâ³LÄ∣g©Œ}ìÇ&QÜØÚyá7àžà¸`3lOð»sí¢®XâÐP8¯ Ò©¶€H·pf @GÛXë¹(~šÔ+4HÅøÃyÓXŠQ][² c„>Û­ƒ¤¶Åy7à…þ_ìz=žv/^6¼DÙæ™ÑÅÛ]b:1I¯ŠÁFѧCÖØ^Ûg¸Î0eðF|à²MaÃFÞÙvækÎx’NM¾¸ÇkX!õÆùTÏéÇÜCO·³eÕÚ‰»ìmlð}È@æv®}B:|eà]^´ÄH7´Äؾb‰ÙÔiˆÅÍ8z7¸¢VÚkÌj ÞÈ«Í N •ó5kb ÜÖŸylcKo˜TrxlsØP‰àzœ™ž¿qÖÁ“кÈ#0­äÿŒëç‚ñÏñS:Ò Ÿ'[îüÙiç£&J;¯ Ñ18æ'O±ï)(Ê–t)\ÓízpKp!º%¸jL±/vÊ0UžhBŠøtç>w¾¢KÏa(^«ºiý.\²øä‰HG¨Ëø\ÛIJ2¤.réÌ6 ’‚Vn/†ÑØJMx© é;ÿˆ—À¡á¦ôôª³‘ #½`)ð†¯5¸IÊ/¹žŒ:È|o-u:; ÿ`äœA‚+Ò¿tÎÛ׳4¨–A_÷TõðùRèŽä8£Ÿ1gÂt©FÎümà·Ë;}ª5ÚL@d Þ*«ÑÚJî0|s¨ ×Ë“Ï{ÃùW-U.€ˆÜR?âþ«õæiퟆªî'/ï¢è½H…ãËàÎñy[ílsM[—ýZ˘t_ÆÊAmlW'|b‚Øç¡#5tÍ["˜n„Ã=vº†´c,…3º_eEãg·¤|‚Û Û3“—t@µðåÓÜ6¶}´ÖÙ@YóàÀ à&YÚ=}C ‡Z’þ á)*}`{`c°Ùä84+munŠ§UŒñÔ:…¸;äaÅ.gòÙùg}ÌàQîPÇÂü® ט A±>¨‡zÑú›}Kpaæ ºH\ø1$ 6Ý)´Ðg ö”HiO-µ.u:Q‡ór½­ê® ŸO r§©X©Çµ˜ö÷/=Jr:@‘¼ð•’ís >•ÐNpU£e!Lœ¢UFèFÞ€n>tx÷E„T#Á qd>Í€€\¼„ {„¨i^e´–Jõk6„í&í°~q‡·žqlpz>Írÿ_ÈêjD;šè3vøŠWŠi ‹dúÒÕkWE\!$\K±:7Ó*Gs hòeƒæQ`•.+JЛÉý–‚Ø‘O/ðÄŽù  s6=´ëƒo0Êws“D,‰Õs É„¥Q·~ør›û´ª ‡î¶D{SÓÈS¨€‹/—†·XùóÁÏŠŽéHÿ}Ž8äQ«M›å]œ È«:ßBüÒ•Á¸éá´ª:]®-%“)ŸÍù„¤ìœ PQc>.P¿{š»ÛjàÖ_›Yþ¼[0ÅõË”ߤ½ œcZgÖþ®3zröãdÄš‹ÈP¸%gªº‚™ŠÌø(öU û^i6O×õœ­ìí&Û>\QAŸÞª,FMœõ­`á°ð¯pB{ñŒžæ+Ø&NžÏJŒµeÆ]‚MäE½~Þ[¨þ oùe6o/X¾Ð9®§sjVç¸ÿ²lp¤T‰R)ºÀÌ×<ƒJÀØ™/àRÓB Å@Á¹qÙ ˆùÿvNUÓm»òe|xEvÕ÷ Ø??ó)H¤Ôó^ÍôÃP ]¶ 0}Ÿ}q‹=5ør¶pgj*ñ‹G,øÀ±‡{æK‘¨Wµy™$BŒ¿Ï~Y£{¶ÇMAá{BLèK!x  ls<Ö@Ñ匨‰zJëÆc逮i=.àù4bþ ÐHăo³¸gÇs9ú w&ñ8û¥(×Q?ø ‚„xcÉö0 Z–¼m]bð%¡ TkŸïƲõø¢±"£íÂW— ÑøÙiM¥V °Uûé(ó€´ƒ+B9¬™œBáÁPÄ 19-/^‰/kã*£òí÷.C ㈊[±‹S— áKI=nŠ†ž·”‘¡@—:\ ÁÑ7ë)­«øîÕ%Y$°­g|¾°ŽŒçÈ(»: 1Óx¶ò¦Û ñV•!ò¿,Û?úÄSâñ5>´î;ÆY#èpÖ=¹Åà¿+fR3$@Ýt—Gì~½„Mû„]࣯ԭfKà1óÜøï'ÊxF‡B–î¿ ¦W¡5:Ÿ_ÂÞ,€_ïÂO˶½Òš8èçÔlpWIúÂ'’²ÌAp~]“x|:Éóîó1Ð:øÒZ¿‡KÊáSHR»òµ Ÿ¾ál^?ÒÈáÍiZ–ßTT óyë²n_SÝ|>YÆ_Ûƒ{•ûwuÊ\“Âz¿x^6ºwØcát¾Ô¸l=«ÎíºÚS&ŒX®Ê–’­ËF§><'N÷ŠÜ¹Ž†WƒD¦ð7–Ø"KAÓàùâ6x¥u –„:`¦öz.fœ®àtÑnºÄ‡ns/|׃pµo='¾Ç-,¤ût†‚téNºuú†þÿ”qUcÜN©¦ÿ¬h>„ô%0üý- µóÒš,xQ=¦îW[$þÐU^‘Ÿ+ÆVF|ùa‹k\5 Nÿ¥‘Ë÷oVœóåÝ»7ß~óÏm;º†ø~´´šF(ñ¥O¾›Ù½ÑhAF:¼½‡'罌Uî±Mší8غCG¯žDÆW€¢ûàâÃÞ”ZP,d4øå„wF{ˆ=þÒîû»¯þ°¾ó@ endstream endobj 615 0 obj << /Length 2944 /Filter /FlateDecode >> stream xÚÅɲÛ6òî¯Ð‘ª²îËÌÉvÆÏ؉Ë~©¤*É"! y܆ýòòõéF\$Ê/ñ”fNÄÒh4zGƒÞæ¸ñ6ß<óÌ÷åݳ¯^‡ù&só$‰6w‡Än‡›$‹]?ô7wåæ'çÓÖÞKÑ6Û]íö°ýåî__½Ž¼ÙÒ0uã<¼zÍ»ïß½ÿHP‹ ‚ÌÍF žÿg=—„õÝû7ØHœŸpé\”bãÃ7Ï`E”˜9:ŒüB‹mOšKÉŽœ0uLJÑi†5¥a÷[ßshßÄ$¥¿êd–¿|ûâ# }†¤ <'éùU`+ˆ.Îðv Bçí‹÷Û“™ MW3‡»)ﱉÒL-1N&ì—‘<ËÝ,{2€K…Y Ž÷tÅÔÉYQ %ÿÛ"dÁE ˜­ÞùĽ(ƒFäfAdS>?=[µØ3wãl¼|B÷ˆÕ 8šœ‚nÏí¥Ì†bÔÜŠ4è¹Ms¬øªl‡½ëz^¼Ìi±~îTD ž)õÂ/8“hºA]Êè2‰µ©‹”¼ÞWVs0Ûgj:üòfSžñaJ€'uµ“¼â5Ì[ÞÄöè_"Îó;´¥Ä^I¯šÁM©Òþ6LHø•—Y¹g’yQ©h x_r²bìMÙh\ˆ+q<)jŠFÁm<ˆÙ³ÞRûcl‘Ö`cw^îcÌp5Q‘C¡/ùpÝ“ô}ÿ݇¯©õ¹òR¸ZšÉ!K}õV'î^ýóI$a¾VQÉB2¬}V+ŸF­¢¡û2h:Üǵ?…°XÈ`xS’r’M5ÁÞF¡ÑµRŠ½¨L-#ÐU³µhf­¢_^/f6Ëès“ŽØ‘“{[‚Ð9†Ž 2F¶¹;¹%9í víaW´ýxKï˜aö-½hÉÕx}ˆ~ ,¤Û,òW}Ãé=“:Eƒ¦É©ø|}êô¬¹§ù’cñ¦¼)ìí³­]Q6Ï–0êN„ÈN[»ÝÞä#Wtpv%X±ßL„ˣ̴ŠÙêêiXÄUŒÿ3»Jݨó¨ } Zߨÿ%’c ÉÆ^ ¹b- ³Q=šŠÇ|„º¬£úiä†þ²Žz=ÕÊB7÷‚ÿât³’ñè^f%൳ôÚv§©¶"Ê«*X¾=²Þ2»(ùI&óÄzµt|3´¬^0 ò°FB(²j"¥âõM¹ÅûÞfXcNuËýØ!ðy Œö9=iCnã¶é%ÚáÅþI´Û¥[HÁpêÈûÛ*êzÀ˜¢Û‡¡ª-î̓UJ©ó"‘Éò_¾ý0%ðS¦~v«Ûen”œÝ·>ó$™Äñ(:ðW~žÀ•H“ÐT-+‘R£glieös,Uìi¼§V=VI5$\Ó Ê“)›™Ií0°qb’ðíu1 ‡úÁ4Zó5®òqm—š'Ñ`ýVW£Àõ½ø¢v׉Š÷&ó³Ã¶ÓºJu“¬që;:{°òX©S;M:Ý&‰5^ò<È L~i³Z¼†RnÚÇ@¥¢%¶¾ÿöÍ;«Ð'€UÈÈK¶&ÿ+9Á²²†¾£ yÑõ¼0Ð8fï œ@ÈLšØ‡£Óµ ç(¼§€ 8Ž÷×.8÷ ®ÆfÍ \ :)”2ú%‡Ç¬\«½·¬]›‡>´›Y`ÎmëðÖ4Ns{°©ø ùåcQ’åò0ÒŠ¦ßôu²b íGÚ÷`ÖâÛ)Ðúˆ=Ïù¶U6 Y;'zéï»~ëg$ŒOSÙâ=Lb}A.C>Øïlÿ NÀrŸ|`ÙY¸]à¹A8+ ­¼Ù$n&KŒpÈÀ‰]ß Vǹfñô³‚UX¢í5ôý•2Ì6܈ !¦bNQ‘÷ÚBºZ c•ýÌZ2 lka´ÓÏuØ×—gß>ÍÂÚ®'ôÂòwiâú^áûÕ p<ÝüýfžûVBžÕj ÈwŽVDóe¯=à¨Ö{ô?ÆrOW^¤ªKäO¨8·dÏ~S¸ZKÄr8dš€@Hjb±’dº0£¬’-µ Ï+z±7ã{VÜOiJ} Ø¿½t#rà½Q‡Ðy81evo[™ÕoÙ6¦…/°ø}lƒ¡çW_”û7C ¥Ÿå¿Y°þ¦š¤nÿ™šh¤Ó¿ à1…-qÐÓåùB¹›ûÙ™"ôUÌÜlŠÌcÄÒ¯ÐðÕ<БE¿£h®awöf™™ÿà;tÇBù¸ÔPʺ®²/NÄÇ<F¦+O/FÅ.ë}ÿü`~õ`‰ëåd÷2—F%AB?ˆÄúí7À2µqÆË þq÷ìD@á³ endstream endobj 627 0 obj << /Length 2203 /Filter /FlateDecode >> stream xÚ½YYoÛ:~ï¯0údÏDŠ/q>´Yz}¯ãdºÀ %Ú&"‰.IÅq/æ¿Ïá¦ÅVnêÜ™y$ÒGgùÎJÆk­Z^ëÓÏÈï’Â]/ [N0p½¾)¿ëw@IÏkŸ¯e¨Œéª–Ÿö¹§žô9pñ ý-ø©Œ–Œ¦úMêêëWi­Ý Š°jœiÿP›× ßòÝ^ß`vN¿Ëð‘ŸKÊ'}Ä sAR¤CBí-õ3Å)•C¾ózÃ+ å]]?H|í4-ü(­N±‰aÍðóÍôÓ›ûÉÅh2»Æ·ýîõí(«O—S«_pž–*rŒõb4¹›}_£Ó-Ô $Á‰ %;Nø;c3y* ÔE¾:Ño IIp–§ ÌꀂúeÃ(Lnmå²¾5• ‡:“ò«“Â0¸¯iCƒã9ÎA{&Ô… ’í mwW/gkKJžmŠí#%F2fŒf˜ææ»^£GU&jÚ.Irf&VµqÙ¦†{Ù=´i4áî¯zr w¯ÖÇ&h¢$—»g $#‘UNw1ùö#Gœ81θQ“Ñ-/n»&‘¡T…Sáÿ@ ™Ä¯‰½Q Îx´Ý@w•M/‹p=8M-jkd5³¦@LìªU·ïHîE•ø˜,½"ÁÍa^“V„ZœÄZv'‡£%>V««2 e£'I¥|Îó5)tw@ 1RqÞ×»‹ó/ßUO˜Ï¦÷“ó³Ë‹ùtú¯ék|WÑÉÌ^¦<Ô㽈Ä%ŠeägEu©T#‘ÉK~‰MRÌþVy=PK£f³c‹˜LŽŽë*C%ª0ÅV èÊl•“øhˆÖÎ@6¿žÕaÁ(bB?¡tSzÀK°¬&. Ü3x¾Ôb½ÃëÑb!ê:n;ÉÑ(<¯ýlèÐJéwMEÚ1(Õê לĮÎåcB£gL·ÎeŒÔê¿`ýÌ@A2 zc@€F ºßÞÜ&ÓßîÎo®oçç7ã—E°0µ'*+ ù¡!‡b$ 9Š*EÉFëncXÆuä‘ Ù$ž×ê.ßläx¥Ž{¶y"Œó¨@6KLÈn×Øv ã¸ÒdŸRj-è¹_mI6Žƒoïýúÿv ä0Q1‚Í®93 NZ–ÿ08íwMùo¶riËæ‡Û‘Ah2ùr sÈ–Fe$Ô ”8É/¾ÌÇ7çúƒ¼1ÂN7”A³³¸òÔAY’m(®ƒÊS±®ò j! ;¦Ye›í-&s›SÍR9ò³"]ìÀÇ÷®|á§0 «îPAfç¿n„£ßNl}™^H“Nl‘ÈìpZ4¦øs/a¬586ó¶êz¨R}  åf‹êóÉéCÙÏXk˜¯ÚÄav)ðÔaê{qªó’Ñþ\•Hã'>aìÈJʲÓ0²,¯ó|?‘s¬8iJU)nt>™ÉÚöJiÅAC$Œß,ÖűÂ~:¨èiÝ–€¬PÊuDd þ/Fó¬8÷p‘º¨Rë"ÛêåGª<¾ß³e|1¯Qî­s§Ý›ÏóÉÍd>šŒf¦A,´²j¹1áò® N+ñžpYQ QF-~Yt‡‰óªÙøÅÁöäöþûÍÇ÷ái+A_Bõ¾ð9ðÙZ)‹]ùIpì¹ñ/欼ßAÔ4xþ@/ÿY:ŠÃ5ë+£Ÿßaœ£üi#¢{õ_»›în`ìƒj)H´ß|ô1òHá÷üÅ~Ð¥«óÊÞžú›²6õq†IãªÊáóW-LÞ:P&á| ‡JÎÉ™³¬Ö+43̲x=W¦ˆ‹Í%I„ªì> stream xÚ­YÝsÛ6÷_¡·J7L€$Höæ’\Úº;¹ØÎ5ít(’8¡H—¤ê¸ýíbIÓñõÒŸ‹Å~ü°»ò»…·øöÌãïËÛ³‹oo‹Dë`q»]H_ Oú ‡Búrq›/>,ë&7MQíÚÕZ{Þ²Ý×Ç2§vZ¶5µöéï†Z:XoŠŽÚ¹Ù¦Ç’;EÕ™iÚÕ/·ß/ÖÒ‘†¡Šé ¿Ùš"Ô _›{"`š¦n¨¹VêœZ—×ß¼ýÙ =?òRÓèýÞT<ÿþúײΨã¶ÿj0XÕÌ`Ú¶uV¤É-#že2 ™û}Qò/_]ß¾ÁCeŒ§òõœ| “ëX4þŸ½ðUѶ oÚýö×——×/Þÿ‡zÛ2åñû”ÏKóÜäãë;wûMQ¥ÍïþyOÍÓW—×ßþÈl?´9ü5Ê }ægŸ²,²“Í4f[šÌ‰œ>‡´kŠOÌH׳îØ°¬³}Zí¸½1ݽ«x¨(­Òò¡uŠH+>q›f]ݤ]QÛÍ`õj!%l š=hÚ…§ˆŠjdaãK–ž ñ‡; °)Ê¢{ "~2p´–œ‡æ$ì+¹Ü™Ê4i Æêûɲ=f™å®T¸ü}%Ã¥¡UÔnZ௥‘zKßno˜ã±Ÿ&B&!JóÃÕ»›žT"¢(v«îÒìcºãóš¾Öø±aªÖÊÛÎj°=¾·—bµ•¿¼Ý–Uµ<˜´rv£áðÈk…¬@…Ñò¡>b#î1ƒGXßÂ)XÓÐDVçÇ·'©Çl[+ÿ$Ä37ÐR€µóz@ˆÇ$¡dôůæH" ã‘P÷ 56¦¬­:Åœ¿­e ®²Và2Z:¿óÙï~¸Û5in!’ÛÛN/H@’•Œ—$Ìöy|ÙS üžJ8u´4ñ9ÑK@"‘Nö¾–Ï_†Éÿ/|”1* {¯ÅkŒ½ÖÞ³àZÇòøœí0ð…Pd‡¨VXAƒ'à&"\4=¸ÎûoÏ@áòæ¸i×ÙëB £´‘¢ fV h„ËoŽ @[s¨ÃN…Hg7VÇÃÆ4Ô&/ —- BÆó?{ž²/uBÏ=vl©s•~\Ix—h9½Ó*ÔËÃJ.ÓjïÓ•òz$Æ]ôÜäb.øŽÌzàýÍ*ðÐþHˆ_Å6Îi¶xvš¹¡–¾ÛcY>Psh|o5ùÚ©«4ˆ® ¤÷fƒœ‹’Üwôôh‡Úပ6°ŽÌ\«—-ØÄI¶Ð±Â‡/C2°•ÞÝ•E–²’aŠ±Í«ÊÊcÎdØŽÈ÷îöGÝgõq·çSjúìÛc¹QB´Öv£[q¼2‹xâ̓O0>[‹2õ¡wÝ )}ˆ‚ï …Gæ?=6–ðžÌÁñ¬IO¨"/”¨& J[¡#Ç=#4ƒuJ*X€²Z/'k>¬C™ä¬ð÷ÁN‚pÖ~¤ðfôÂs _Þ@òÅüÃHÀ…´)Ò½>]^½¾½¼¡6!Þ¼z‹Èuûê;8åtvU‰‚!hz`*> ·¯ /Emàׄ}FbÈ –IqNW~äÑnøRÌ„-ó»´A¬¾2Mؤ­ŸíÖ8;â?òÈ∦5LË o±0x0dIüþh ÊákDy~7&Kíy@ú¬éXÙ'β¦0vx x…9 À0سî£Ä/,û0<âYã;ìPÜúíX4|ÈÞ¤¹i¨Ý#&®"[Æán_[¡Á KÏççŸý’âƤÜé¬ì°U5w(:°óιÖ*l&(‘FIò~z" •ý†aê3qHòÁ¹T0v2õ¤“Íz``”|‰‡)@Œ7/Þ! ½@¾úŒÅOÅ¡S]N£ö9ÄÙ1¶Âº®8&7Éìrú’Ôa5K=æW÷ïyàêÝåzÛN àAÑ¡«}ôö­£ ÏÖb¿ÎÜm‡GË:û¸.{ÓLà~iõ‘&·&¥¼;G2c‹½ZS1áXS»¢2-3r9gC>dY¡~œ‹AZÎ3£§ý)Ãò=¡}ΰ(! ›ò‰ÔÉú±SWž3JLÔm<´ÀfsØÍÍ âz¸|p{iÉM–ŽÏ9§ù¢¢/iWºxlÍŒtøˆ ù`Ylš¾&:È©•ùÄ3«ëßE·§${rÇî>wD¹Â´b6Ú€PEÆðE¸:®lrc°ÀS `·ÈOt]a ÄÖ9IJve“¹çC§])òKÝÈÁæT)Séjºkj4 ´«Ìp$Œ‹R(S{*¶è>£Á)*ìhð| àôïÄ特'Ö““D­O™üˆðÂ×˦Øí»õž’#o Ç€üä¤ GU ÛÒ¬™dE@kC‰3­nêü˜YÃû¦ÐTeLnø°SZæ;¯ÂáG«ûÁôåú-%a§'8îCh”Û±¡aÀÀÒ˜Q9F'}íäž—cýŠZéh¿mïàÅì\²†¯pô*,±ô Gè*^„"‰"ë3Жû"öø~¾dBjT`ØZÖÁûïÍéAâѦœ¹k>ªUÏW¤s¼È@ç4P‡¢³U#EîÑ€é}Ú: ¸º•‚L#Pc¥më’ŸŽ>}*}Æ8yÞ§wWÂWÉø©ÿÙ“Ñd×N¸û›‰!€ýôŠ„¶õ»àTjÆöÉieôl¥cTå@¡x¢Î1£Fú=ä`ª±÷-ù²@a,PÝÔ å+úRì Šò«ËÀ›ø/¹ùÚñÚ±1ÒŸ.!ˬƒӜ|Pä°0îêr}èxªäx\ÉÈœ#ÊñÒÎ×¥jÄ?Hðô…ôC°)d¢ÙáìÃ/Þ"‡IÀ?á'ñâÞ.=,”ÐhØåâæìßô?Ýè: E¬¨0‰ ñ-<Þš6Ú®À›ÎûùìÄ¡gë#K¦æþú H¢Ê]pábŠ9…õ¦­KÓ™±–Û~~{¤@ÒVq©þú÷Ïêœô‡H%¡ú«U®=éT®=5ø3JT.= Y—•KM;ú*®›Î_Q\D¯(¶À{VrÉéùÜûw64gDÊ …Žý… 4fôF¤¼XøQ’êdDç.[,276O„pƒ¸!|”m³ñìk”úwþ)ø_G¤‘ò ðÿõ'@¤ÊV£‹ð¸?®g’Ђ=€b?ÖË×Ö¤‰AR¤-3EûEÆ/ "ÒãÇgÆÿæÙ½[ZJå©1ŸýŸëØEÚúÁÅ;\š6¶C²fžÇiB_U¸¸ëÖ§+ñÝÛ÷ÿt¥oLå+ç«Ó•ú©3_‹{^‰¤¿B‡¾l®CR(f‹’Žñä@‡:ô—§0'œ>@’^Xh04â*n©V._¾yqsNcr9„üœVΤi¸ÀêñÝ%ëøå°Ì.w,ï¼6mõùì[Óÿ%<úÑþ^ñš>-è_Ýùà4HlòôÅÁi"b¬3<›â߉ús¡)ž ÿÀq|n‚5¡ôx4%£T<Úøø_ƒaß— endstream endobj 661 0 obj << /Length 3856 /Filter /FlateDecode >> stream xÚ­YsÛ6ú=¿BÒL¯ÎtgÒ´iÝ&n¶v§³Ûôa›‰TIª‰÷×ïw¼DùH÷Á€øî ·‹`ñý‹`òûÍÕ‹³7¡Z$""³¸ºYH‹0Q‹( …Ôrq•/~_~d¼úãêÇî½³7Q0x)…WRX ÍëP®Ö2•K[×+.«ƒåÎ6M¶’ÁòÿY<ïìNÇDFièÏ«µ‚×¾«k>Aö'º+6w|ê'<,kx~_Û• —Õ¡ÙÞó\Íy\”üÒ&k,ÏT7~¥µ+.o­Ã¶Â§¿ðŸ­?®ðàO¼9?ÔEyËã¬Ì¶÷MÑ 9‹µ£`-‘†)Ók@ˆ^–þ|¨JÄG?•  X–üñºVëë¢å1¡ø¹µ5uçÔ¹edðɃ:MØ+ ã#q;÷`GgßÖÙþŽ‡ŸŠÖvp‘Fí]V²˜Â¡´µ2"L—“â-*Y„"ã·ÉB‹$pLÐÒ4Òµ@H-Öƒ}Àê`$(˜ôðäŒæ¬µID&cÎÛüÖ6b¢¸# Ö¬¹k©€ùe›Õ+{•^«(Y–‡Ý5j‘ŠbR/œ«‹Û»v ìÌù¹)rÛÌÐ!•*Œ& #M@dº9Ð<mù„#á¢FÊüÃ/H¢ FNÀˆ$ê,ñâ—.'a H‡²c €“ŒÃ&+ƒk‡ù¾®6à¬Ã±(ÙjT‹ÈȱðPE•:ÊÛ-¾®ôòz[m>ò4ÒT+žGW‹4ééüõÅÕ[?x(ÿ܈Ny?€GŒÙ@hè¢z¬Bý©½š£æ‰Nã fl½vTU×-es·\íöÅ+¶?”FÂ(õ£Nú¼­gÓkÇÖÚº<›êB\Á &sãõ·çW—çÿþ.2^C1öMR$*#´^¾Aòªº­)•‡ ÆŸ¢)®¿6ãAÂÎu–‘túˆˆ˜‡¦äƒ$†@aDɸ¦8Bw)) %4ŸÕ–Alo±Ë)OYpQN[8Û‡©ÒrÍ_óü Î6¼]þ¾ÃèXŸHès™å…ÑјŸ×স}\ç½S—r½=2†¢ó&Àpžæ²¬Út8ú€[´PR/ïfZ´a_Aà& ð =5nG‡V”7{hN$ iiÜõíÂç¼j4Gœ=–¼6ÃŽ¤/'§¢‡ä¹‡ëD˜^ß3þ6ä9Cvp0t✋@íCÑ;bË^fÈ øèP[»CzçÐ3àõȤ±ËC£„3JlWv<ÖQ|’Çà¦UïÙßLf 4Z?™Ëšúp9¦ïÊj¡Ðˆsä2âÜq™È"GGt B%Nœd(dQØFŸôSÖßx«ç›Œ“¾cMr4¡ˆÕ¤è¹¨ZÛõ`Ú³ „<£8FÿõqÄ™18yf(òÑÄëìqogʱ}qWȺŒ¡9ì÷ÚÚܧ3Ñ;@§ä‘HÒtÄ„i Ö!胒ÀcpEIÚbõä@|ùúgÌ"¯^ÿ0åÍflëéú$$›„ä'…ÓV:…î.ÞtALÃú( GˆŠcè)v\¼ g„‰ÏsJ¦©ˆžð7˜4¡§!àŸ ÉĪtÔgÇÝcìC_[ÁÊu5K¤éÀD•Ž5}H"0GQ¾«×”äœ;²¿js)8uj2<“5É©Om¾õÓìàÆ^Â6Î6G•-©ÓͬBäÇÇú€sßXÕJ¨8vVìùBhMâQ‡Õù­c¨‹'9“O5!ñZ‡6á¤r‡ ÈÔƒCì8‚»fL ÷r¡xÏyEœñv`Bª¹¦œ3(øS¢¯úÂ4Y^º‹‹™ Âß:+í¦±`-?òh¹«}É…u·<òZ:€0Ýóóî@ÒÖ®YŽÇŒ <„Uñ/Y•àñ¹{‹oø¯C_ÐÍ6Œóª´ æÚÍdyî‚ê´¾Ãjs½m6U»¹s•gtüN?ßN]÷ê"ër¶Âi«k `ÉøœëX¢é*F|>•±ýZB8mP”bÛ DDÅÕšJˆ”Zf ©E7œ€ÉÎ-—<éJŽt,X 㥮fÆy÷}ÑðÔ.ûèÚ90×òÜ¡<4L8ÎzW;«<ð€î­$¦ÏÝ幄}žù ÝóoÎÌÆ#/.$KúÔ;–z†³±18ŠÚE %ì©~µÂÒ`kðÓ(Õ¿üÍ;:8,ÈIÌ¥ÝaÛèÑJôÜQt½«xÖŸ#£amxÚ­§ÓúÑW³õ#0Ô¨>}}Öu26:ºÓcv>rEª¿íȱ½l¸ä‘ý—ñ¢ê/m\ÓŠ¨drå_eÇÊÙÚ½Ù¹¿!ø¦ÚӽΎò§ÌÐ÷$‡¾c{°cŒG™ÍÊ`Y¢ÆEÖñÓà\~‰j$Íßjj@"µ,÷Ä;~ŒÛ6ÏÓÈè“è U&Ì ƒEdüSrÿ [üÂb' GÐQN(J 9ýtÝDÜWÛŒSyé>Ç’)–3j,‡€‚dÄ2ÕzV¦0=–éZÆÝ…Ð;î—â=\ÄÕîÓ2¥Õ©ÔW&àߢi_=iþ¡HzvØó}2#q’³°Ø±Íaœù·èfk_[d›$Ô~&œÔÞ9hpÀÊ–;Î0@æ|&8.v<ÍøÌe`çüÁÇ ëq÷Pt‰›»Û%WÑÕ1\w9˜\fuº9‚M%^6my í£¡;>ã®Xiºp[ûâfx`‰wÉ|÷Ðq²¶`aÏ30}qú%&‡/ú¯\ ¦&ðåvÒ}?…]Ž“Ê¡!ÛØJE–ó:Ê8ÁȇΜÀ/$K&„¦( Â%þ:W‰u)µ+® jFUpËXUÜy3e:~’„Ge:ˆ+#e:é\]-ò`Ï[(c$,æ(a‘ƒ„?…ÅË‚ÚîýG£'(¿¡™“"Æ1_Sé8Áa1á,Mwq½öœï€ 3ãøåÔ2 ºjúçÇ€dÃùÁu¤bŸÃ|“í,O5-½i‹#qVºÒH¡uøw¢ä³˜h!Í$n<ƒãÏ¿–Ï„/#¡Óô ä0þëkµZ›Hù,ô9þIÄ}Ïëaø¡:Ô ßÉwV#Ñ7’»«$cÜÝ#Âøg£xêÚºÝU185¯YZS–ÇüÆ©=nÿ¹4kº‹¨(‡mÆ„±øö]á}n_ÖŽùîS71ú:p9Z¤ŠäøÀÇ12󉣣ïcúî Þv© Z$0?“O7cØåNß–Q"‘Úµ^¬ÿÞñú¸ð£ŸXáú—ñóë¾jºkÛýWgg·n±\‡ê^ÜÔgàLþ±¼9ã.ÁÙˆþé/a×{mLº`´Vü…I§ ü·¥ endstream endobj 531 0 obj << /Type /ObjStm /N 100 /First 893 /Length 2677 /Filter /FlateDecode >> stream xÚ½[Ûn9}×Wðqæa)‹,’B0@&'r1rìn²Ý“ÑÚla2¿§Z”e9±Ô±éÉn±«‹u¯N$2ÎDò†8bdãSÀL q/ê(FŠŽÉdfŒÙ”¤c1D®˜è!â(z¥ìq$õOôÉ^⃡ä0aL²×;l¨Ðao¼K Ãb¼×7ã-Þë«%ÏÞ"'ã"ãNR”\Œ/º88Ã.‚N ÃTo˜=‚:Ј!'˜DÃI)1œ (‡d‚cà ÛÖ}…bc“1:BÔ ™ Þ½ Iaà}!§Ê NĨŒú^ã ¢^€î(‰¤¬K·•#X¢àn)¸o„FrF¼¯v žð}Pï”0Šx­Ö;“¬kŠ‘¨Îx8*w2…% °J28…Mrz¶¸›pJ˜D“|q£(bRð Š'E,?%Ò ~Ê€!€ŸJ—M&¢@>²ÇFT<é60Áæ° ƒMú‘@Hr,ú“39±NÈä¬[…ð‡ß¯ÅqfˆÆ >šâY7ͦ°Â{ 0Ø(”˜d$Û’Têtì¸d@,`$ˆ ÆùÅÆK€¨ •’qøXìœBøa–°§BλºÀá®ÁqÌ"NH‚þš@Q‚>›qòôÙ¢;ƒ¨‘ò²†‰è!EÌ‚²ÒF`µÞÓŠøѽ{£ñë¾tf|ÿääô|4~µ88ﯟŸ|?uó·êÞŸŒ¼¥þb4~Ùž›·Ð9ë!džŠucïŽözí±î¾¹wÏŒ_™ñ£ÓקfüÐür†'OOlùÕüöÛÿÀàd“òÜ%‹ÃÀ˜m† zÊÖ]ƒbqpÄR{(T²…üBùMKóbÐn,þ°dŒVË 4–ŠXr¼ ß–$6«áô£âh)„ÝXÂ`‘` jÉ!Û¨Ðp™ãn(ñ D¶”– $°œ$l1ßEb©Ê O ­– iTÏزðVe&w8ˆm€QóP!VOïqÍy;Ž»Pe籨Oo`½ ´ó\ˆî¦²~JùáÉ‘ÛXîÀ¦d‡w#üI– :W¥ @²aQš·êœyiÆÿþÏá-b%£Þôd1›½_­Û;=9ïéîÁp„>bÄ{ð†⹼Р®oy{¨ÞÃ]L«g|Xêˆ÷秇¯:lËŒ÷î™ñëîë¹y¿É©ýéÇn4~ ÝÉù¢¾ž°òãìt1?ìÎú`±¿õ¬;:žþ~úÕôÔÀ"u?ûÓ9žÅ›e¹®gþÞª¨bÑTÇ÷m5Hr°ÙÀÀi@S É.n× ß^“ý!€öü³† 8v(ò7’ÂáG$åÒAoˆÍMO]Ê7§Ž¸ö†§Î©žz®cYŽÁÕ‘êèëX¥$„:Æ:J+½Pé…J/Vz±Ò‹•^¬ôb¥+½XéÅJ/Vz±Ò“JO*=¹¥Ô"œ½,-™²æ~XƒI­×¼&7~?r:<>ïìôG‹I¾U8¹ Dc5¤V=„}4UÚ‰ähöy‚(‹bñΊfH+,LVS—!\é&%w ¡0ÛL—Ø‚1!iÙ åh1ï&™" bK浤DØ(Ë@$¡!qVSÆ ž$x~—v#ù¸˜-&Ž§ ¡$„iÄk(0þ> `Ê—ùt6q-™’‘j5e…Q·ÝHö?=ü×£7¼|öâ̓Ç|hŠ .Cóâ&&è•ãA5qñ F™Ýš;Œ°6É;÷qöP"ñérì‘°Ö§X ;¦ûÞ<}úâƒË áp€©[ÛÑjegžWOïÿùâÏû\C?À!Ùì׶—#rú<Äö‚ð|1¹](u MÉy}V04% 04óÓEwÞŠæÉqmh¹€héo'[¦³¿'ÔR„³–âK2i¥x–Y÷õ°-WŠ Ö¦%’¤]ø¨8€+wÇgÝáçn>¡†>™¢%‘ HÄtó³ 54½Á#Úgº8£€8bˆ¸ÌºÆ88"KM*‚+päìøhvK$›y‘G¾ÌÒ€|,æ²,@)2ç­\—­óh¶ 喂ʉ BVhÒ€†/IWÚv:Ç‹IiXõ ZÍ@ÒÆÉFUŸ(–ˆC‚ ¾kŽl"aÈ ƒ%ˆëlNjSÔ C0ÿÅ__oYɶiý'8X­øƒ7EϼÑjm‹ `NjˆÌ)H 2ú †òE›ZJý‚¿fô’wgôW×x¡ ¥Dë o_ì±H“lAˆ¥IòöŹ ˃·‡Kñ΃ ¡m‘a‹ãÜòÀ jXèa¯·cœ2UŸœÍRv-V±!mgZí¾ ©œlÔØ6ªo·¨]ÃÕ/} qE ï7ÊêÆ6¥ÕAzV¤ûn¤¿M…F蛺œ¶oX¡‘Z!‘Z!‘Z!‘åV´;¹cW÷SsËʈð ñ¢œç#2=mXÂ}økºl½~¶ÿd2ïþjéBñfí5V$A]iÜ äèèè¼EÃlW7bPB ;µdS#9hY¡»è‹šÚÂÑÆ/}ãO|äO4Þô'úùIïÈÕ‘êØ´ïãE?:€DCŽØd6a«UÜ8Õ»èýÀ,ª˜eµ~¹²Å*n@á–¢®AjXAaÄl,a8”†™ŸÖ´r¸€¢IO¡€¯ª—ajwyÝE Fègk?¬w ´kÙÍÛЮeô&ÚÅU«˜švQƒ–ܤÑêç3XÕ±îκš*“dÅPhïŸúÒcòÔxJI¯R¡`&<—×]C˜-´I˜eæa‹CTk5F' „Á9÷_N [Œã—0\€~Ç»¢I¨~öúÓ„ˆxÁ¯9GïàÈó½ÞýBÔT2"[ý>a=œ"”¢*#ûüy8YŒ¦8<|÷6 Å3 t¼lŸjÃ]3nýŸ àœË÷s©Çžžãu]Ë:1b\+µ¡FRƒM§ÕAS·‰'¹õiü¤ëy endstream endobj 690 0 obj << /Length 3408 /Filter /FlateDecode >> stream xÚµ[K“㶾ï¯Ð%Ušª˜xt9©Š7Y׺֎ã—Ž”ıL‰ ;™üút£Š¤(8;¹¬@<Ýè××Àl´xXD‹ïÞDÏüþû ‡ßhÁ\ –¾0‰b6Q‹õîÍo¿G‹ ~¿ˆ˜LìâÑMÝ-$O`j íbñéÍ?D$ãHÄ _¤³9K´ö$ “¦2>~þîÍ·wo¾z¯¢n)Ìâî6I˜”1lb˜Ä®Íâ·å‡w?Þ}üW¤#Îá_~óûÝ÷¿ë±(€yÉå|OJ0›!#?üòÃOŸnnM-ã‹+¤4,‰_ƒKói„Ž–šq&NP1ì,’ùLh:ŽXlõ\)d2¥ÐX1s’âóÐË´h³Sö;¾ÂÞÂD,±f¸÷.K÷ùþá¼æ^acic¾våÆÆfï<áá@C_¦q…‡kË”äs€ó)½Á"Ó|ƒÂõÞöç¿™q¢ ñ2¦†¡$³R™ú±$ʪª¬¨™îÓâ©ÎëóFò ÌHT•R_ÀLg8³¹™Ð¹2LA¼›)‘R¹†ÈhÄó}Ù–C Í”M†{^:D÷…¹d“Ýßph‹¦K*“ª~.%²Ròj.¯â¯Óþl'´/Ó‚¿Šö¥…ÔèÍ™_Ðþ˶j_sGf¸çû¶(è8ë&mòºÉ×ù¸1¸W/á¢Óál6&t(ÓF¿Š…aQHqA‡/ÛrZ‡ý=çéð¸¸IþCšïO¸èH•­ËÝ.Ûo²Í3:›¿ åBž4¯”‘9`×Ä›é_žËÈ—´ÿ"ž¦•ßçižò¿œ Ô½Šõ‰¿ï×yããuô–~÷/JÕsÙ€x@Bq>âMÀòV(³Ð‰`J[’ùîÆ‚ «"i³ä_“qÀÂŽ:â¸PuÄu|›®ÿxtçTmhøÄ”¶Ê‹¼yÂ.½ÌëºÍj^eÍc–í‰0”;GÂ\$,62Pž,µF¼€AC…ã¤ûÍU|àzC¢ÈHW=i‚¯J܃f©ÚU‰2~Î7Y¦Ÿ‡²Ü¢À¨ Ì9Ñ É’ƒšÖ©WT"—å=þ à.£Ž·ip¥0*£þoørCuY´H %‹ÔrWÖ ùœþaÎ.Ø6ÔÜ—¾Aïýd§¡y÷14$œ J …¢íξfØdH¼iHë´Îjæ=\ô"l 5@d| ÷eú¸ÀѹŸˆÐý¾†#öëCZÕÞ+<‰ÛmÇa픢ÂÑ Q¾ª´¾ 0‡ŠÌ ›N5ðÛÝm8Iøµ!丗Õ,ÖñI!.¹ æš·iM ­0Þº¹dã õ'r ËMVQh©©Ê‚>R¿4ßÃ8h•¾î³´i+/8úQŸþ¡(󦵉TCëp “Ž8ü’ICc ø&¸æ¦­ðe8?X<}@nˆ(`Ÿ Ô”û…äu7±Þ–má·XyR è¹Ëœ@G¨Vé‚/D¿ k¯!#i=SÐHÛf[VùÝAÃ÷À*à{¶UpÈ,‘Ò/3 ­»¼ú˜UžÅˆ~¨ÖÜ×¾wpú𧭤 èëÆ^4LäGr‡uô¼5AÜOoì|ƒäÑÛ‹‚BÈð=w1,WÀ†ã µÖÑÁNÚc‚Î* «´ßOp†C•5Ùæc\Bˆ¿¹k DQG@¹]BÀÍðÌþ±GÆl ‘|ï´µËM~6vú%s„agþ0æ̾É<]‡— dGœg‘i­yE*¬—;¬ógá÷÷‚HÏûÔ™ˆc;[Ù¶«„XþºÍ0„Ðbp«²AkPÑÈsgà‚†Èr¡!½ª€†`^Ù6·åýmÈcJêœÕÄ`–ÏÑ@ eû8Ø‘o@D²Pà&õ{FôÓwz5Jƒ0Û9½;‡c“áጽ]Èg]0€N'X¸ô‘uI-¼Ç–=#¾LÚdì4°ð¬Ó€I$ÝŸŒ`>Ù:4ÂŶ 30Ôåh¯üôŒó#Î{p6…5 eV0nG¡ ‚úŽÜvèý Ös¬ŒdßYº9Ån‡+ñ‘läA v8]î\ZÂ~Ì™ŽL{(=fÔ ãUž hÈ@Ct¸;ûgâÆðLÐ9Œ]~˜t< KŽ )rôf;ö¬­ú{®N[>À©ƒ©ùA†f}2äº AšüöBÐ冀tmßßz'¸É»:):u»Ûe y¢¡äAœ_±’ö°¹Êî´êƒz,¨Sz¬ÝU¬«üj1?2ƒJ„’/Á 2Õ¯ã(%> a¬ózšËcåÒeÿd`gN8ä ŒÅü´9)EÓýPQ ‚ÚÑÑ|†¹¯É›®|mÚGåÑ’û´/ÞŽ6–—jŒäXc˜q¡z%Æ;„Ð7Ü.Ëâ Ç…ì3–SÙhÎ0nã /—!ߢ£(TEwW…â(˜x—ÑX VÓ§Ðò@Zéá¥X+y.-aÛÎMK²ƒYî¶ ¨%äê¿ñ…]!ž(˜|Ö—5KŽP@P1^튡ƒRi™f~ýÀ[D #Í~fÙGœ–mjÂå4ÁÅÏ7Rá•¡îB¯ð’Š‘óMž>ìK¼¢ï]V×éCæå"=cË™†R'ö´–áˆ"=GËhïÌŠ@íjÞǺWw¹+Ô†:·éˆzwD¼«Zy`›¡k‰PÓA¸ÓÁvðUæ)åe[÷CNÚ:ï®$0üT™ŸxNý4$Ö>LU}¾&è‚Òøf³gÅQŸ]é:#<×þ=²:^ºÕtåãî4R´&ÒÔs9¼°õ—pý [—xë6 éM(éÐù€Ø"VÙ]Ã&f1ð´‘&q¤n±°ÂVÏ0áëhŽ°,õgÍR$³PkÔ­xÌÏ!hxÕÔÐÞÃ#T‘^ 0ÞÀ~ÖøÜ¥énwp¾¢ê]ûà'Ÿ²•fâªØ1,¤´{X hª$V#)~òR ?€Ãh€#Vt ¼I“æ…óèîeøšzf‘8`ƒ øvæY2+íéüÿuÏé,sD^s7ï@ÉÌóf&>µ#yÕîv7GÄÒ,Fë_¶Æ}Ì×® ¼öò0_Þ<üiWf²Qp«;4U4 (ùIq2âC$ ¡nV¨.Þeï>|üxûŽÑç§, 7Ïà1—Oñ›_ÒK\ zpœ\á›› ó„h¢Ø‹_5ñ$ýYžïÛ½#Žo]!Ò;„In$‹OKç ¥ÏmXr+ ÀÊQí"#€XžbXùŽ-¡‰È†º2 0ÐuÂ,S­Jó§B{ ¨+TgŽ®. o7Z»;kЬêŸ`ÅR‡£þŠÛE:X=ùÅLM†x©´Ë”åJB$§ Iý~‚úUúTOV¥`5¼3½]»;L¼ #˜8è4f6¹øÀ+˜I†¯»ƒý„ÑL%DÉ$þ¯ ,û“ SÀŒ‘멧Ԟ¦}Fi"¦¬}$Ø&T§2œáäUsTƒ¯_Ôð öú\è”ø¬³C«0£JÿèüF/õÈ÷¡Ó\ÅÝD=$e¦HQ„QDs†Û À'Îì±cX”ÃDŒñ):àÓ]Öл›Ñ¡ „)»ÖÝÁ@ßÊÏEèã†Â¶a²öw!Æ!Âç ˆìðEû 4ãßc±§&QQKIä3tˆªrü?/½`&ÝÅO*>%EÃÄôö}¿Ý9ÀoJóê¦j×î k⪠²(7ñ3†® 6µ:†Üƒ5§úCW±bZ¥8V¡OU‚–™ãí¥È ˆvùè®y:LÇ[·ö$ÜeC¼­Ðõ8äz®¿@6Ž¨È %eÜg¹Ow?ÿòn:È Õ»{Hʲk\Gô]G,Õ8#üñá=æ 2ç€{¡Q§¸›ú"Ÿ³St5‘¾ ƒ†»p-w¥a܃é}[wÛ;Ä凲®s0ä·ä1ž:ŧ8È}܈ Ÿ¡joç³ý>¼;­žº±¼:VoÎÎ}i¾Íèê(iw–b´ï]Yw¹:a&7C}Q ʬ?}Aè1á_ø—æ9÷’ ÌR aùi¾Ä½ð?rX¤$ÁaÍó¹Ð½N Áð7÷Q1þ' @ηøö®=ÀåÑø¨üÑL}n endstream endobj 721 0 obj << /Length 3660 /Filter /FlateDecode >> stream xÚ¥ZIsÛƾûWðHV‰f0ØRõŽç9õœÈ¶R989@äHD,‘å_ÿzl„dÉ)—…Yz¶ž^¾î¡¿º]ù«Ÿ^øòýáêÅwoŒ^)å¥a¨WW7+¥CO‡Á*JBOjuµ_}ZžÚl•ïûë·å©k7[úëcÖÖùg.ßlt¸®jhÚüyõ3Ìé¯/"ƒSú«­Š=_Édï~{wù‘É‚tD¦S/Š5PÕ©®6*\ÿ“ïm³Ù~ºn,.ò¶Ú:+¸ñT5M~y›ò×mÅ]9o‹íÁr÷ìm¶&IÖW®µ±…ݵyUò¹,¸«Ê¶®ŠÂî¹~}?ž OY7jm[[7x"`¬ï)ø®jä°«|øéÅŒ'[9-pXŸò™ß¾úåêø¡Â%òMÍxeà’Ǫ¬Ü?oqW›¤nx¿ªJ¾ºlâÕôOxI’LB¼5~èn‹N`Œ­wYÉ×B×t§S‘#«±–5, ÑdÛAê¥Ã¾³¦±Çk¼sY2°•$v”¹¬µ«ªzŸ—Y+kÞ°ÄÒ†l×Zs{%ô™l-/o Ëd –;Û4•£¬… ,GSìó|½ÑþºkIˆ"ARÍBÌ-,NPèçn@@£0ZÿŠ[ºË{©Yç-ó°p-#æa Ž{ÎwyQL½®I9³ÙŒëй fà÷û…3Àm{qHPƒN«äI'‰f' 'ˆ_®FtÿYb€‹£\Âþ’pýzaY° i`&ëÖ ó¥ž¨ñ¢/7Û0Vë÷ SÂIýtz”Ý”‘‡“s¼^äŠÒéó§º\˜*ö4bã¾HÀÕ‚œ$^œ¨ÕvDu1wnJPåå®î;Hù/5†ç¸e· ûÖ˜v¸¥¥ý À:Ìr¦RÂà*Ädì±Ý™Z¢qè){{F ‘ŒÓ‚ÈD„_¡[ìý" a3 —1Ù2›x|³m#çvUÑKbuE€Ê|‹~ì%C<ü4©÷ˆ…Ñë/€è³äs²á%H(oŒMf ÇFjt‰; ܱÆ( ,4rmG"Yí€:VØÌCaÌe¬l¾oÖ¿T­l@L!¬rÇ~€Úìh?Ÿ¹œË®zyºx’ ,äÞ6ùméì&;-æH±E Y}^ÎÖ1‚ä·â‰A$÷‡ï-™™F #v¸ ƒ.n@îí±ªe,³‡äG+ „fÄøí': ³á Ü5?›ÖžºQ‹¢1ØÅçL‹Ž¥"‚‹­Q*¾èˆ Öp=ëÚ î ñ 67¶¤DîìV†^ß3Mëï!¶ÞòÝÁmêd˽l@N4»x™Cõ€‰k2cõ¼l ( «ïO"rÄæ@ ]ƒ ²"Œð/Çß®ì;ðÎæ 4BÉ€›‰«™Ÿ‰ƒ­(v)‰é5ç)ŒQ<¶x³üD6# ñ#šPŸû‡¯âÇrn©°ðãHBêJBe)ÄôFO^üýBaØ»R`ùcOÅj„ ¸³Ú_|úÓ_í¡8JþŽH«4õ"Ê««/Þsþx†=e.(*'ƒ$šÄÉÌb?'¶ @1k‚»ãIâûdÈÑÑTöo0wm>xù­ª’î\&Â-(`2«vB‘t0¾çUòfIÆé_»,ÏÓ³¬¡¿˜eÕÏβRÅ3V£ƒsYäd æd€Žõ¿Þ?a$mÎ?!9mbåÆÌÞCŸ)€Ó±Ìœ©\–¨âä`#Ç:9F2Ï=X`<œL§Oº™d’ÿžiøV%p.&ö5L;÷ý¥@ öè÷Ó½EiÔÎBAò¨PbL=î'ºíS]Ò’ÂÀY‚Ú‚Ú&&gJƒŽ§ªn³²åªKh²þ’í§=OîmpA`úÈ*d¦Ì`s9wå®èöý Épˆåë 2%é±ç˜—lž±wo8ÝRÌOÓŽVæ8åå»×Ü÷In%‘$ ”Þ['óäåŸâCƒÐ /–‚þɾ€eþ 2Ù—‰Æû‚Þ;°[ÂçÁƒ`õï.kòíÞ–LÚc[ž´íó®†c‰÷r<è}äxúã-º|СHM§Á{÷ÇÃ^_]Û\ˆG(™ëo ÁÉéDˆ±ãºjÛîÄ=€ p]ä ½âÑŽ¶kìb—ókJ’Ny±çjcÑŠ´ŒN”âG;øþLs$°¡]ðœ²j‚aɃd(¼éû:Ê7ÞÚ’§ø¸;tÅË•›º:ré·r¤pJŒÚ /Á÷;2àÄuUËLȲË_?ÐU*ýØUšàAQÕ‘ËÂÖ^ýº,~õê¿||¼Mõܺ:°?*=Az¶$ŽIäÈ8š–ÎŽ¤:¡ÿ¬ûÌ5’ÄHÈ'Ã<ïlËn+os¼d¿EIÛ Õý"ïò²´MÕfKbòØAÍÙA=6v/ѱDŒBAº¶Ãû6ÏPWä^²"Éyb‰³kÑ,éN4¥VK"4m¹‰4‡‹Ç®i§sBˆ# ÷³™hà LX|5sns[×Ù3jb¼(êËåÞƒL^’Æ+ÌEiôÈšN!æôa-ŒóLÆe8ßþò˜ß†`Ô÷{DBQÕ·¿™ó·/TÉe4 |«XЀz àãvJ8I(ç¡0vøÊÌ>4ð›…;|l•^‡­.øégü°N’þ@K¶÷|*ÆY”×NÓWPÈíÈ q¤%!›Àš´\rä.ÚƬsÂxXrHŽ\[ëП‹¥{Ð7•[’}÷²ôP¶åhêÛ°Ë볨2ãÏäQŸCÝÑWA7(oŒ^ÈŸ¸_ă5Þ@äÃOÔÑÚõõé·gyƒŽœÇºçÚ(™Â CbkpÅ,øÀ–Ô@ÛaÂÀz “ ¾¢¥Çö¬Óãì†r• ¾ìð]h‡ˆø18ž¿µ?DLóëhɱ% ý"Ì8³É;Îl(]”Kibhp—-fÄäÁ/”çP ”ä7Y!«%‚=2Jý»6ÆìŸå54&ðØC‚By¦¹ŸÇˆ1h½:ÿ‰”~^ˆÈŽaÈ{ÓÕ˜½8V5=6ƒXQš ÂuÌÒˆÃcð6§E±Î6 ³g}h!-€/>×ÓOÖ$‹æ»è‡¯à8Ç!Ã=‹CZ‡^bÔ7è3Œs£ŽÙ½ì‡…Jc<UÉã;>)/‚5'ŒbUÞ9ȯ×ûþÙßI˜Òý/8zægìàQ,] ˜îÓLÐ&" ¥JZö9l©ff+%©bYO3ï•ÖuûçàäDúé|öø`ò¬ß:% 7TR¬õÙý.Ám=ŠyÐ{‚ O¢túÞ÷,÷ù¡» ÝË%tðíF^C˜_¼2÷9Èù. žð.6ù±äËOvÏp—˜T{Ì=å™$xŠ{öàÚ÷Œ™Ðopω ÎÔ9y’{ÿ€ÍD½÷˜üV†´›ò£³Y¤¹BHc@÷G†۳ݮ«³’ÞKK)Gt?­ix >8?$³è×6-f7$3eâñÛ%[º!_32Ž°@U»ìŒ-r÷Àá+Œ©U’dP¤¾»"ƒó²í†™¦ÙÝtË}Æa|=Õü³…È÷âD,ˆàŠDíÔôR@Øþ¤Ìà endstream endobj 741 0 obj << /Length 443 /Filter /FlateDecode >> stream xÚeRKÛ ¾çWpôJ ÄOõÖªYµªz¨|ÛÝÃÄÆ ª Uî¯ï`pöuá›Ç÷Í Œœ #;–î/íîþxhHM›²ÌI;žW”Wœ”uAù“¶'èþn`eÖF•dàêÍ^u0ŽKtÍÒÆN2¥üUþ¢t´ýE¦èþÀ9Õ!mtôW«ôù]4h§\„ç ¸”iRø—Œçö¶¶çŒ6Eå£X^dg¥õZ[,3C¼WŽ` wœeÐycÕ?ìÇè¯dôVT`Q‹¯6ÈžŒ•Ÿ{“ÍVÎÖtÒ¹HÓT™ó|b—.`u6Õ«s™&é­êâSé^>1&´ò2"8XôJ—êC*ÐK×Yu Žyñ~ *q³•Ú°Þ`ü~Ø¡VQ%_Ü:"Ï©fXèë‰Õ·‰­íì8šçcVåß¿þj>±‚q'Ó÷»¯ž×4çõ–H?†6*ÊŠ›g”•ÙMEYQÅ.Þ$}kwÿ\Æ᧠endstream endobj 757 0 obj << /Length 3273 /Filter /FlateDecode >> stream xÚíÉ’ã¶õÞ_¡Ü¤ÊÆÊʼnԌˮØåd:•ÃØJBwsF"e’òôøëó’ ¡nuçª\$,oÃ[ÒÅÝ‚.¾½¢îÿo7W_½‘|ÁÉ•â‹›ÛãŠp%I¦lq³[¼[ "VkF)]þ´âtY·ÝúجX¶¬·ºmËênµæŠ.o‹m¹/»R·«_n¾7˜s’'vh98Ød`k-˜\þÈHSØ‘‰—8µÈIf½æŒdÔ¹ÁÁýAÉ—ì눜þ!bøÌÇÑ.÷þÝD ¦¯;;¥‹í½mA;¾‚fžMuŒ`¨cØ2thG†ÃÕn׃0<¡Š¥Í[©Mxkﺣ Žš#éIJ Í&¾£íêã±wUs@8ÎMÝ#I6 ™gÌeaK’æ ( Î~®¼øÁò|y±N  µ®ìP{ß'0Ø}çöÀM…cÃX÷’ÏÂØ/vMw_tíG0 ;VWûOnÖ(¬vÿºbh†ÐpëÖÝÚÿrn0¸ÁØ`<&¤ïØÛ• ãLi¯!)0)sƒýoË»ªDÔ°®Cʥ̦ Ú,4‡”å öÀ±˜îÓ*DÑ袭+0 Û{ ¿ ðXQÿŒÁgÂ7;u{l¾‰íßpÓ¢) ”ØŒnšçÅDœò©ˆSfdi¦6Ú@⸳#NáÐ*ì®}°â²ãÕé°Á 'raÌë—U;;×ÝŸÚg}êlò•¤Ž@“òÜéjëèètëÀ.tÑ L}µ"*æ©Í¹[D ÉD"I•É¤¡a“pˆÈ§CÙ" ‘-Nm*ðP]¹=í‹ÆŒE~{Ú[¨Òáo;À¾µcG· ÖMq+aŽºElŒÝ"ÚÙÖîÔ à¹2O“Œx>3æÏ’íwÎÊ° ªO÷~ø÷?½Ô’>K€¼$7Wq‰3ø÷er¢¦e€Ja)æe€#'œ©ÉE`[|1²—g[V@“"=ÉŽ%Aa0OÓ¤gi ¥¥CQšãòúæê×+ÐÖOIŽØ/Þ^ýÓ^¤Ìõ¸¨$ SC©¡ 39¡ýYêPRgÆÔ ã«‹9†@YO‘pA€W»#ùCŒQ’’L¥_Ré¡FTû˜;± +ü™aœ Ì r"j(È8”šÌ:—D’œÃY㩱‹™#G‡=ã…Ö àˆþõd\²×èx¶úØÙ>¤àèÈq‰[+–ïK¬Éí´¶ Hï1±òèýîU]ý®›ÚvlŽ?¬’„ªú°Â{Ü`i¤Hi@±óE}á¸3@Ú:50a267è}õ¿ã®.„êóÝ•ÈÏû«D@–ɲM{=â¯rȳä1Õã§üóWŒ³øB"‰³3g1Á£À’È“îöC„£Àa_G(±"Žs`< %ÔÃÌ|r{ >B…{¥c¦XôeTŽ¸úeœÌ—P×9²³Ùg·P$…1qÜéŽ;rpÜœ¦ã •b^åc±3UlX7:æZàðQv¡6Ó@›ŠP«Ì4¤©±w„ng66i¨ÜC;ƒ“õµ›[œ8FÁÓ)ñù¹ÓLðÂ5ÁûCÚó 'G›oÃê}áî”ð" ú4—õö2¬ž¾ø€U¯]¼±8ÎÄnw/‘ôÞ¹‹÷øÈTJX–†±°h# ÈÉð¨â^2x6R<¥Á1f±·Y"XpŒm-$™4BQÁ@/*óPÛ‹Ê<Ï^ *€‰J²s§å¤óÎRpIò<öy„}I í³ï_§oÝñÞq6ÊšÌx£{ŽÍ¿)é ¹³U¸ãŠ!W¯b ¼¬ÏŸb@>ÉÀL¥£³0Ùy- ¤«‰}–ý`±ÚO„_ÐW–¾¾æÛ5zòðÛ?;<ò6ØÚÛG|*És6»ÛÅËüG“û˃yœbT!³ÏŠTÇ''ÇÖÓeóÞbÛM3=sÁ@ûSM ‘$ý€?2·ÓœMžËÙ®£BÂFNkDv.iù™²$š·HþD= C–užÖ‡(’á½û¼‚QçØfŽ›ÖtRð§ØNžÃö&š*ôQr™Ÿcû•³}Á OY¨â>ψÙGP? Làjp¡>íyË‚Ô÷,‹É33Ò÷‘¬.­’±sxïÈeÌ,%œ­>ý8#EPs þ’Pà™Åš¿¬Ö,eQŒ9ä’yÌNî^&GVÿ%«ªhM©ò°¨|uß*I#¨Þ3’2oMÓ@ÂÃ@’¤³ë¤ÜôLìà™RÏ/ÀÞD–Ÿµ·„$ù¶7þ˜u¼ôþO]¦ùIÝÊf’`^dùòöÿJ÷Å•n”lúÙ—ü¨'Ëkó0F¥ýV$â9É^úÃœšdÙ/¨Û£Þâ'¥vcGy_+;ü:…ªxAš%„1vùN˜ý‡{èÊÜžÂg^ –˜û³ é|ã—EÆIáI˜T Ú»Z󅤿_m»æ´íN¿FE]V±<R^š&—ñ.·.‰&® IG ±d`PÉÀý,/ø†ºüŸ¥)¡|ò¨ö¦´þ‰2´âWɘI ÷ ÌEêÞœqÈ~5âoJ@Š; RØáÙ÷E8x¨‡h[·ý¨áEdîiúUÿô®t‰=,²_ÖÄêbÁÉû”—E<,ƒX›É *;žñ§+»µH8d‚I(ÃË·ŽWy<¬ò¬q ÿ^ }¹bK÷½;tí÷î¶aµª;Ûyj»`©R5NÌL8â·[mm[Úh8ö}1Ôw°¸-íPf[:½YlêSåV™2Ìíï‹NšN p`0ö k¼Ž;SšÞ×ó›Êñ·ÃàÄñ“N²™{ô˜|úúæê¿Ó·¥ endstream endobj 669 0 obj << /Type /ObjStm /N 100 /First 892 /Length 2652 /Filter /FlateDecode >> stream xÚ½ZÛn¹}Ÿ¯à£ýÂ&Y,^a¯ '6a;@¯ÆòØV¬Õ(£°û÷9‡C]wn±[Ë`w›<,‹ç;ÅjœIꌗŒÒ›#Ê`¢÷(Åh,(ñ¬(J5%“b6•ÏR0Þã(Ê&R.›((ÙHFY³A»^"^LøA {BÍ(è¢àB3Ÿ$ã‹G-ÆWàJ9˜àJš¤,&„ xMåOjB¬ É„$x M„œÐN.&TÇÊÕˆ¢TœÏaoD<Æ[9F´\Øq—J4’}nÔè©¢r%ÔìMtƒP”À„þaü (»6‘ƒN¥àBÃ$ d.™¸2ê䊞+^®h,;gÔe‡ o4xÁšX!;Z½òI4šBÅ…ÍI'Ù%tïøús‘¯cz<ÆœF*¯s€æ6ƒO¦U3ÛA7ÀÄŸ"\ðçè&™o‘FÈ‘x<Íï¨û0üux5<ïÛÍdx3;Yš÷!ë1Ìà£u„„`V !Zô†zÏÌñ±Þšá/óws3¼0O^=ÿû»_~}âݯOŸšŸ~šàïÇ`:­/mÛÂõQ½U,O2ˆ? Õr!a}ZN"õžÑ([øãV ~L S´M¿¥ï þØD'ð ’)ÕÂo€ÐB±èá„TlH·@ÄË8~x‹ÔjkUÄ «;K±Ñs«-U×âXN?žÍ¬ßˆa]§ˆ$Æßñ‡l}E4©p‹‚Á«å÷¬¹~¸EÄðìø¸µ?<;YžÎχ·Ã?Þ¼âÿ'_—Ë‹£aøòy¾ø2³§ç‹Ó©ý¼.óÿ ›Ëáòd¾<ù:<½Åù¼gLræþù¯#.Z‰ŒõÞœ_}ØTa³UT”Qx¯ÊØãlÅ>¹WeÉ“È~•CR‹°¿_e+âà.š ÝWÆÌr¿îËùù²9ÁK2ìˆí­—xdau#ôìEÜ V7<”euƒ‘ÞÕoÈ«âõ;àyõ º^/æ'ogp3¼~ñÒ ïf¿/͇ûîözúe6žÝì|y 6ÑÆC»œ_-Nf—„´G›}:þ<ÿÝ4¯L€+ãßëéïÒŠV¯yð%z%#ò¯Vvl©…äkUj/{ýœ{yý^]•ÅõÒ÷²·Wz{¥·WVí}iuk{y›ÁC¹7zÄÚVÜáÂLdœƒ˜t(*­Ñ6gÁ]x½³^3¶ °¢Èl)VýV–FÞœÕ `TD^°–¢–Ô4&ÜÖz8–ü: "\C` ¶#î‹? A`*ÁÖX(W$Ya`,¶†r@4‹¶#¨Â3 „°vêÖ9Žº1'Pp¦¼uŒùèN ]‡û ;ócàˆ.¡_¹Ál èà84Òn`pë®~BeƒºÆ©9M¡¬âˆ—´ÕMÇe²ÉVƯŽÂ<®îƒCF ŠñCeW¬C@Î ïAh®Çq9kLÎúðCÄfŠ­Ä8ï™W±Ø[qèˆ02Â8¶“kÁ{ì{u/iÌyÑ”$(s@*¢ðÖ/ y+Œxyb©ûæ»õà‚è(1-cIò¶W¾a×Ø“ÅïWY"Š“ý*¼ZÇÛ×Uöuø7à{öïeŠ©^ÿR ùô£0]ZÿÓeÒé;™né̵tæZW&aNnUú^†^J/c/µ—©—¹—¥—½=ßÛëæÊ݆LíÊÞžïíùÞ^ÌÀÉŒ{¼HØÝ™1¼Žã)áyÞšÑqãxDÀH78H [öy7_FÝ_*”ÙYÐaò¶@ÂÑRÚ°¡\LÓ/‹éÅW«6àŸ?žƒ ƒŸ#€V± ±•îsÞ Î˜Û‹dÓÂ|3ܬˆr]+eCÙ ŽŒ™µ!7G¥·£Æd3¬Ã ¸#ÅF÷šÈm¿¡šažx y\ñ/uLúÂm‚³L«ÉÎUêá`fëŽ=2U:vX pÛHáa®ª´ÈÉérf§¿}útTÓˆHH#“¾Þ† ‹„}(p=9ÙdvyTóˆ@0ôÍÀËc°“SŸºÉåÉ׫#çÇC„¼CH v„’ ùJêÎÜgÚ äbvv6;r#Ú„99ìo!f mdÕcoR3åÍH¾M¿]Õ23 …ÂÌV KF¸¥úwëãÚëÙâ·Wçã 8Ç5a,/Ûáòê#ÿ®ù»cÆúÐrR Ï…Ò îÂX–îSm iiÌP@CÁ©<n÷§4ØsµEýfùtõm~Tët<$Ðsà$õ (ÃÂÙŠ‘HvÇ3¯I¯Ð3Ž‡™‰I¢íiÄQå·ä€Ù`r=C+ ºúl]ž òˆNò€`±xžµ•'­Œöôè/ç·¦EFåÁa"à C.ûÆG\lg»vûAãÐdü``½y¯ÞµvcbÛ­9FY[tdE·WfŒVÌ,wrÝ¢ ïJ¼ÍñÞ¡ ض†r}ïòº”;§.ß+㟣|¯`dú¾ 2ùAAö9!ê t¶B]™ÛcHÜ$l‹1‹#§c.íbiïÄÍ9DĘjùÅKÂÒ–,ÿOŒ¡/Å=¼ùÖî9Ë7úÞ‰×ü§‰WÝkâsv'>v…»B]¡Çî±+þØ¿vů]ñkWüÚ¿ÆQ}Ä(x„– Ìu%hÛAËzz7=û2?ù<¦n Ðó\ÔŒ- –_†iR›7œ¸Ýg3‚aDáâ—¡pÌ—È€öÝUäü°€ )uL©Í*<çI·Çº  S¾%‚ÔÍÏu^Ç ñ†^â¨J’Çjß> stream xÚÕZKsÜ8¾ûWôÞÚµi.ß’¦jNÖ“Ê”óØØ©šªÉän9­JwË‘ÔI<¿~Ô«égrÙ‹›¢@@àd>û4ã³—Gœ~Ÿ_ýç7#g)ˬճ‹«™ÔKx:³I´˜]¬fÎ?ÿuñ;Љf¨¸'øÈ…%=¢ÑÒšïD0ÜÌ0^ÓJÂd–$¶ßcÁY–%žJ ÕÑéÅÑ—#+ùL V,IÔl¹=úó/>[ÁËßgœ©,}s¤Û™L×(Ðfv~ô¿Øá`™3k Ófrz=9}òóO6a",S° ¤NÒ h©#Æ’É´“ç_žB¦ƒ K”òÚñ†C>–%ôÚ-«Ý*ÂM¤,Iu”±Y6d÷ïÈž“Â>NtùsE'v*°[H¥™‘°/,Ððë(/Öes¼†Ï«ë¶¬v~æ`Ƕ®6›båŸ/oœ·‚ï1”ÌÌj¼tááýKð>=T—à‚©D]¼zñæâì#7\ø+ˆ—¿·i5È(²°ùóh9àÎ\ $¬bnôo%ßVL/ç|þf¿Ùx±¯ËcÁç_ñOÕú©UÑKw`Ïy(5ÖÀQÇ×^¿;(T‚ÞDüTKƒ{˜yÚãÙ¼]~p]5MyYnÊö†ÞTð+‚~nçÅErb%Q\âU]ùßÜ/ÜæÇbÞÖåw⳯ËÝ'Oq…ÇÌ—mU—çxBó™ –F^ÁÒ0vsbdi8)¨Ô4 úÎüm}ÁdQ;ãKý 㧽ñ $¼pÚÓíöÛË¢&§½ s[•‡su…vùZ® šÉÉÑ‹¦-·y[Œ¹µa«:ß}þò‘s¹,‹ÝYÝ[ã½r¶Ðà&ŽTu‚FÕ–8édÞT›=iž®×h¿¦x†é¼ÚžÜ ïi™%ÏÙD˜Dˆ{[¢¿iÚb -ÒjƳîzü up’T’_£q.‘•žGnHÆlÇ`™ÓÙ/IÚeµ½Þ·Áß”€’•¸o¼S-B~JvÍë| W¨~lT⬣’4÷9¦…¶‡†ß³1Pï/Š4NfÅÌhÏH/ •°Tȱ^µx´»«ø›oš Gjà8ßVþ—4ˆ7~PÕ~MîAwÄýÈ-_Ó™päÃÆ’Æ/Æ3·ë|"P·rB¯Ñc¿¢GI0¸¹ÛS–&\hžÌyÄÏ„²`DpªD:´4ÒfÞ4Õ²ÌÛÓ\,ö.Ö‰&1·lÀžƒJÅÙSÜs7cIS&)³@4Iš†’æ ç;¹÷W€jÞ;àÝF‰A:x)Ç©!´ºåh¼Ä8’·ÁDs/ g9ÌÀŠeš0âeÞ€«Ú}’¨?Ãg˜G©\YTÑÓBBÒçÞàšÏŸE°…æŒ+Èo…iz´ ó¹ÁZKîlú €>ÁààŠ¨Æë7ô¬ÛP42–¥©ß`K¦¿©·§}_:IîN'FvÜI”q€HéÎÓpÊ(œ]矺,Š]U{tD|;Ηð®ƒQH7…Q~M9Þö£ Aœ:xé q¸à*¥¡N¿¹Í(¾ÔÅ—=à’Ÿžšfôíiî^‚4Ô…Ç"Ét6ˆd0Ý;¶{÷¡’®aF¨ŽjŽÚ‰Dˆ"#D‘B`v:Ó„¯‘¤»ÚCg’–`¦ gGòMè)  NºÀ5GÂÔôJøøÔY‹üÏ×Q‘>V¿»,ÇM<ói¨§ÍD71$ÛÝ7ä[Ÿ£û£p?F˜7Má~ Ýa™K7 D²LN³¥lsNð`,k °»ÀnÀÆÞÿ_â$&(™º#kLî8&Mv@RÅD_·ŸDöKç`wзÛc¶õØÞ‚ßcïŒe= ý5ÂtÊÍ`RwUã<›’^ßJðT,åäÙ6–I `@=’`i–Ü{¤äÁGr×}Îãl½òÏÁ;qÜ[%ùG(¼°êò%.`íD™I$^uЪLît࢒NZ¬vAJÅæË>¯ ?Õ]EKùØ"8_u,'B´É:ÇØE¶MXÖã‰<4ˆÆŠ6Lõ½”?î•ý!\âù9½(£ã.pyÀ“„=ü¸¾!1í ‰ÝYvã³ù:¢3l3Ú$V“ M—żëŽ(n:ýÑöHba~vo>T!­±…ÎÌüMå >9噜—»0C¯–yC#ts8P1!¸ªjEê•Ÿ(6å¶Ü…r&P¦(î$@,F +–Ä@ IÛøßë¢1¶AÕFCœ™äÛaê²ÆABzFÙã19fÔýÜ…f!ÔЦ–oÅ*šåø4¿%”ß~ÃU S§O×oêó ¥Žàæ½éÛÒ òS>„ò0ë ÎzuÒäšÞŽ dcÁ€â °Ø&dÜÄÈÓ_~Þ‹Q—ŸÖíbíJC|n¨Cg {O!®ŽeV×gØàOq¤CÐ3p-@â`¤Vœ©'Jìûùaïèî1È2fqjŠª¶Äv›ßøÁ%Q¬Êf … 9Çãm­³mÍã¶Öfée¾Çpƒ¤åÎO¶.¸âŒE8Wí67~Ο×æËÏ=«önËvvOíÈ×è[ýñÝÅŠDÄäOsõŒVõpìÎa´4KpÚa×J{J38ºñ8ÞæŸñؽÚî—k?jŠ]CLK¢Íé·Ú·‹êj±¬êÂO`¾*ó|oc‚?ÞØŠcè*¦5DÁ°•‡M@I§Ç%ƒV<¹Óû!œ@sª—7][ßlª|å10y6¾½ª«­K¦Q}0¾¬ÚõD†á…|².z'RP†Ýd‰ou¥zâÈaõSvÔwï8¼ß›„0œSã3üb\.÷›¼Æ›çHª¦Ý¸o_„/ñØ•SGmªÁ±‘¬‚’íÚan˜qmiø½¤g_¦ãÈ_}?ZâÕ°Pv’Á…ÉÀÈ!Í0AHFÁó¬êߎa LŒa 2$iÇ`ƒÿŸÁŒ”`ÆI]¶ëmFõŒÜ—΢nB'ïnq^ôesS/–ò'¥º¶­×2L\ƒs矊H“"Ëú¯÷wt9û&§«|[Øùˆ”—›ðÌ/‘ŒdVwÐýýéÉYŒ¿`Föåz„ T²]aþß·žŸ‚‚Bß½?}ñêüÕÛ7±&€e!!~«ý/÷ Ô=ôÑÄS<Ï”ÐÙt]ñWqñq!8”ƒo\nh¼Ë·>JÀ4hóÕ›ó‹ãLÍOÎÎŽ3‰Sšdk‰Y`RWM9‡%þñüƒþç]xÝœw ˜½DÝ÷Èp¥±Í&5Jÿ«j¹ßv=´üúzS†ÏÐáÛS¾7]U{ú²wwº¡à¯vÓPT…€ÑžoEøFU~8õY×uÇ(OøÖ1ùeœ^ŠI….¢¡ÔÕô/1l’‚¦ÿ˜›ì˜×Û.vjV“vj„Ò3j"59¦qÅgÎ\GŒ© ’Ïî P—Y1íødþ_n~8 ´(0Õj¬GyŸ D߬þ ,š ‘ü˜ï[Ëž¦Ä{bÔ-*t¤°§•®E¹°øHBpé¿š?vœ^ý9 endstream endobj 812 0 obj << /Length 4151 /Filter /FlateDecode >> stream xÚÅ[KsÜ6¾çWè8ªÕ0¾œÊÁIm²ÙM²®X©=$9pf(‰1‡œåöòë·_àk0²ì¤j/F?¾n@êêþJ]}û™’߯n?ûük®´²(2W·wWÚD‰Â«8ê«ÛÃÕ/›0È®·Z)µùq8m¹Ï«ë­‰ÔæT^kµy‹š¾¬ï¯»ýççß„ÙUdql‘ ºÚê$PZHÝ>ø©ÞÜ7ŽHsÇ=@ÌD@Ì8bô¶ìømßðoQwC[ð»Ü‘jÜQÏÙÓ›|¿Ú|­£Í#÷†v¤üm>t]™×B·*e÷eS×ÛP›ÍKö®<•|>tÅ×H«R ´ŒWÕû‡ºüï ks<¿©\Ò;™"ïX>±šÉ'ÕA¤4$B§¼íKÇþ©|{IªQ(˜\¾"†íæë¦î€Y·B˜P&êîñx,z wsh¿¿‘Q=þšM×'ž*Ò³©tl7Wéã&°*vÜvön§ïP=ò}ß´å$_’à6TI`Lºä;øƪpó«R¦íz~8}ÑÂæîŒÂ{ãa- â$tºaÿÀ$ûX5S3³Ñah5ŠõwÏ|&ˆÆ•æ2ŸdIã{¤©5*W[£7_”žé2Øúøj6ÖÍ8W$HÌÈÒ—×Û(‰aÿÞ{æ6Y`Ód1yÅÃ@̳a°[z"xN' &Õ*½5ðÂÇHqzíYxÄaä[øŸuå•r¤àÈÎ'[èÉ|20§$Î6?±ñvÖBd6yÊ$â ‰'îëƒ×°fs~PwóVL£{Göt:+¢ŽÒIØÎçW²‘ûø¥‡:8ýX§nį*RȦXG!6jQÈzi£'0Æ¡gKÞš\t}×´G×a2öð¢›G.©O7-x(n’K‡W°r°Hªç.z…Cȉ@£-ïúí±ˆÐÑy–mbØm;:«×Y¥Y4[¶æ v,¢`âŽDå=éȼÚ7Õpf’0HÂd)¬$4ò6a uFúÀïŠEGÓ,>jóúͶ©åi8ò¾µŒàã[7&?¼EÊyÝç÷Ò…¾—éàРөmrt{8±ë%÷G­R~wÍPº‰ O»oÙ úŒ“_—h\K.0'Ý·ø§è¸WâÁ*H£’仲*ûÇë8ÓÉu€î.&ÿu¬ @c0†‘7È+«k–œ7û¼“ ~;ª®ß¾èäë+Häà7'P ãS÷÷æüs7T•Lƒ&±?9”{6a…4Ƴ0aÜÂ÷í°ï Ûà#so§÷"îk„Bm÷,5Lyûàåá±Î¸4$ì86‡ƒhÑ­Èx§ ϦÁ9PH¤ûƒ-Ø‹Xf‡n¢åQa 6;ËÊ{mi:ñÑ^[/ %Œô AèÝç°þšÛ̶rÆÄÔs~Ñ•÷5‰aVÂ] œ°:ÕŒ” nàЪڒ¯B*¤ÑÐ?èYb~ë!C2b‚I… X Áú~{jÊq=ùJ\x ¿½NaøRo„Ê8ñÆC]/ל+.îœUÎÏhv¹ÃCwEߣ¦)šiªù²RKh8h˜àç:MÞtŽü¾QuhÇ{x<6>´ç ÁgÏ/ òìyˆ]óëPn‹ ðnö¨$›ªÈãxŽÖ­j…·W[7ܨéí5P+º‡¦:¸ ç"Ïl ’>ƒoB®î_°µ§*ˆ]Î÷]=yÃsæ à •z’Oâ-òñ&¾sLŸÖê§D€Clú $ËÌbD_ø@" òÌÆIp€L­8õ… wòÛKˆéØ›½ð¼m €3ÆL°Iþ4¢Dþ’Õ:¦ÊìÕlØïèb°yù€ÐÐâà…¨a¤'L¢Œ'áéh¤âÏu p {Ò°\ø…r|j~(°Og4aÆçÿ/Ùº4ãø~¬•¬U9Œ‚$1søœ˜œ’ç Ò7pH ¢2ñ!&‘ÂÏ}9ÃØe7Œì**(ÀŽ¬ç©olÕZ­ n8åa7²µãz•W1uœL‹4ÖÃG jú´v§±ñQ—ˆhÏZl«d^ðP)@aò6’ªP·ë¯Â󯂌)Ö’Ë—4<&gÁâlbkkT¶ùþ¤ŽÉ¥ú€šQ _úöD£iŒCFUà° }ÓÂBNM}Ϻ“¥IW¸‘ª5˜‚pÁ%1ózô®êYIÊ¡'Á@BŒQ AT8:=©Ú?4MWø2_£SØ©h½Ý‹ŠV`fÎ…p¶ò{ÅĬȂc”=¥I ¢‘HÒ§›™¶³æÌN–¤/äÛñèäóŽ…ž³ÀkçPõÜá^Bý¨V¯RÍ1áât[÷E è²âz¥"\äÒ¯fô1몊u"'ØŒê‰ÊÕjÕ’™µB^Ê>冒 ²ãFs‘b4‡œå‡N4ü§Âª^]µèHÝÃOè…í\èQ˜xt_ÿxû=:b}æˆW …IGéäL¸ÖšžÁµ~^…¬Ô€‰‚s2•4~•ç®^kÞî%}nêÕxqWòCëF8™}#å)T»Ì¼Ó¯òv™_C&àÏÊrÕ9, #—FfsM,ïÚ¦î)Ç€WÇ¢hp‡ä4öwçüs×ýùhª0s›ª@eT0…Œ*½Ø úPS]²Û™Ñ5gÕxÓ =UF†/¥Ö˜›?n»áx$/ŸBQ5û7è÷²ôoŸSêŠ/$´+÷K]­«ÒÕá°A\cc> æ²ÚlþMâ¡áå³Ñ\sÒU¦#”¹Žwv´@œ©yÇ&'íز;”XâÇ3¢Ð·JfQäåÕ"8Ò!ãnxQ7üÛˆ®i3¡*ç1#«Sâ²þ’…ªìäRn|‹îš#’Ò áÃ{9@ªùèè¹ëhE‡Ö‰Ñx#U7£gy Ÿ¢îI3ŽXð¡IµánQ–Haµ5ÐÞ¡©²Âk§T·ˆ”'Ôüã„ô§ÅP}å-*‰4ê Í’y” 4ÉæǦ/c¹°:3¢3¾³õ„k•OgõŽrJ:1>@JR“bs(œ×«Ü9"žö]G¾"b:;| •Õ=J«ʓުĥÐGü2=µ™¯a?Ö o¸&&›Æýì¡g_jÜZÌΩŒIý¹+¸Ú_÷ãÌ—¼Ú@Ïv0ÂÚãü¬uözRaxpÕÑ‹UX‚˜HŸ³€nò3¸»åö ÓAzûÜ ëàR÷ý¼*l­¯¢elŒ‘¶Ú;kÀïÝÑ«f|Làvî’Ü.ØŽ ²4ž (\Û5ÙÓ§²:˜2´œ°k™!Ì•é3 ]݉2Ó.ÎC+wíXïÉû1|»ëÀý‘1ÂÓxÂS ¦èÞ´ÑºÃ·Ö YEêx),©®[Í•g+bq>ØåcQÈH ã€Fb”‡é *|N¹®û½@]ɸ±w¤+Š@Á«_hðëa×®ÔÏa™ö2 wÇ<øšL™YžQ0«l•V|Àûòˆ¡Õžªqòe;!í°«w„ÿ?üüë׾cÈœo6¥ìÁ±ö­Aåx•Áéðó‘s¬‚0Ygû,àœ­ÏæG?õÙý¿„Û, L¨? çûØmGø|Ü•µ+;æ\Ú¡îËc!y‰£ ZßSÀ»!aFŽ-oËŽ‘¸×0c9%xÞåÂC׸©¡÷¬ÃŽxþyäæ‚¿HÑÅÙKÇP,’šKÅïûeÈx(ﶒéäŒo¡÷Pv4q‚û`³j%m:Kúîð¸QR+yõ‹ì$n3©6ÈÎ7Ú® ú·@ lqyIá™l âñÚ’VroiLe)œ6í›QþÉBOÂ@fñ¯sµ„Þd²€š™‚¥c?÷5=¢k´îl Tj±€ xk± z¹¥ä£zõºÕ¡Æèéè:ÏU’¯¥ÁÇßè ’ É=ÏåLð«Gþ…äœÕDZ$©rÄÙ*4pjKª+|”u‡6³Ñº_½üéÉÂ+4§[äÎuŒ¥9üy~ä€Á‹ÈÏQ ƒÐ9n<ÂÕÊÌ+–… [Žu#ˆõc:ƒ3Êj,*D]² J¡ö剒;ìàƒî„\ݾ |»ãN9€cãNº¬ë‚7cÏe,êæ“BhŒ¦Ë§p5|Z®6¿Ä¥J6k¾ARw€}ó%;üHÒFú~´Âå[›¸ª-Í:Éç¾ Óš'$<«‚32Ñ… /n²<S5j±¦Û^ËÔl2a“h l‰ò\À×ì5¡!^„.ì ö4Ð,”ýØñ¼tN‚w»Øœz¾94m¿¢û;Òf7TÞ«Š»b]B"HÇN¹ýÈò›…ô2|®áâ‘Ït‘MIf‰…Æÿà øÈ×à¯eŽs^-œ—4ŸtíÓ¦|1x&±Ô±àù¥æ•ŽEÆ8Í|ii”€²Òõ h ΆÖ;°%iä†ßc.£vn ¯œ’Kxü„Bª£“O[Ÿî:a¦t|äüƒ•H¬÷Âì̶µüƒZŽ+&l®Ó§§¡Åë>ì×2$ñª~?Âë8ûªwî¢KìB.¶ðúÀ< !™Ç!çb<¤jøjEŒeÏcÓò‰þG¨‹ ƒh:óú8ËÐŽáJXÀ*>÷‘{‹¹8 Ìw•Ç]^.cÔBäQzmû®Zã+àm=ºIÆÖVå#žsuîqhY—ÓÍ„±ðå+P£ >«iÁj?¼ún{G*Sº``Rî?Ë–%{}¡db89‰ }FÈÑSÈ™Êîr]b uÁZˆGìÜñ ž@Žîj¼0 X~çjÿn—F¶¸/$KdçFÄÙ^èçæŸòŽý&m–‰É ·KTçŸ%垺Ë)qílüÀIÛ$lÈ ¤zóü³ Ú^C†r3¿û„@£DxLŸ?°KDò=š†'¶µÅ‡²=»p,ˆŒ¾úþ%Îòõë›UÞúzŸÿòÕu†·þqÀ¿ÜíZ€´ŽâT\+»)x^¬¼”{K¬Ð…Ü^r™‘\ŸµãáþBÓ(ÈÂðƒšÍé2k)³òªkx.W”`^VÌéà<Ú|ƒ<ÂÐ=©²“{T¹\Ý:ûñRËà‘Üçi_º²0^äš2)&i`5LVY4û[n$á,Ú:—ž¶¸ƒ¸î¬ãçº(¤²Š†¯#˜0’&Ï°ÝlªˆÓñ;’Ìù§‚ðT:.ŠµámÙ65–§ß¼Ú‘Ž?n^ʇq¹[‰‹*ø—þÅ„Z„ø­å›/ËØÄbÃ7~´¶× Cƒç¢ÃòhñÍßo?ûz\6 endstream endobj 828 0 obj << /Length 3422 /Filter /FlateDecode >> stream xڽɖ۸ñÞ_¡£ô^ C\“—ƒÇÛ8é¶;¶|ÈóÌ’¨ž¹È\Ü£ùúT¡ ©¦¼Ì89¸  ¨BíÙ›ÝϼÙË+¿?¯®~z¡“Y,’0ôg«ÝLª@¨@ÏÂ8RËÙj;û0oLqȳÅR«pÞdŸº¬lMšã<˜êê¾N‹k˜ùÁÜÜ—UmÊ{ZËðçóB¨>¶{†‡ó:ËÓ6ÛÒ¤­ùöî• Èëªebí>miÕ”b‚lÒ†±iæy–Ó¬ª·™eá·Õ?á’Ké‰$Hè"‡tó1½ÏàßóæM·ÙÓ(Å3“d~‡¼¦õmÖÆ©júÞ­‰š/ß=}³ð½ùêé/.º¦¥­ëŒ [Ó¤ë/ggIǦlZà3mMUÂM£ ™?ËÚÔäŽTIß}…b{  Hgâë…òæÉQ„ZÍSú:ì‘Æ#5ÁœµÐ¤‚€j‡ÿôÂ÷†Ú×ZxIä,™Û÷·wïmd$*q8¬´ÎÀÕgd.…B °aŠíž¯^¿iêù“›üêy*ÿöC&øk ¤þß`¢±ðã`,LÐX[)é%.µðÏßfEZ\,Uâ,G;4•Dt?„ eóìÑM¼ø„º©ŠCU2Ò·ô„„Á¬Fÿt“·/¯Îî«{wõoj GÔt-DD'…Ú'š¯ßßNÐŒþ +áûþ˜æê—·ÏŸ<›jt"’Äwò€0 qý³©«² › ½‘ß»‚5‰„<ï¸Uµ…jÚ^B €0iÑ{Õæúx&ü× EìÇ_T’‚î%Šâ™näÿA©$üN ¡“»¬$ÆBB#ôhF¨9Ó¼¬$߀yQI(Õ¡’XÎáÙôTÀ´ý0Ì`¥­+lµo áàÔ_XõÊ8äבz{ÏÔ†'Ï<«jrIŽ¨¢8ž•Y=¢óîà”цõ–«/ûØp±+½…2¢F6"¾76Dzľ"-7- Ž|ëºbMm Û±ÀEºåÝöò×jPØç ”@Ý!{S[CõáÀ5×r‚iŒ˜e%H¯Ko¸9¨ê†V)%'\|cÊ Ù¿`Ѿôв}DJFmÌ°^ÙóxÑK lëZN¸;FÛg†ÏˆÍ&àpþÀû0hbŽSÁJ#[†¼^d™Á¯-¨p@æ†#[wã uÈ} ¼rÀ`lNÛNÊÃÙØèkV–™Ù¬&ø¥bnXÉQG±ô½Ê\P&åx€Í%Æפ–{;˜Àµ©ʌ@ÔNÄŠõWixNIN¨6¤™–¶²­À ™ŽR>Ä\ :È´’Q\ûöЩy÷¨m«Î½õÄÕ7¶SšÛ©7]»¬vK8ÛöKtÚ.ݘܴǯ7JOl:Ðù›×}«ö­i>Ò²iÊ5 @R†¤|•;mVrÇ K¶‰‡¥"5 ¡Ž UL+;¼²ãÕb¡`êñÍ.352H„Œ,pc¹ÒÁ8šq[g'+[[ýN}¯ƒqàÎ]Cº>~ßS™ŒµH¢þ©ìÕÓ׫”²RV _x6÷BÙgdW@1•øÑØŸ^!ÏÚÕòJÇgï°ÄAÕ"e4`5´6Ø!€¢0ì~¨MÛfîЊ¾l8âGeD8Íü‘¶=ÝÃÞ>“ÛãmÂãMžhÍKèa4²~y)j·¦°‰6±ï_ðiª¼ã¦Eö´´"í!Ÿ¹ ðÚ‡œ@BLêjZ Ã…ðIzs¶‰_ýe2w'§î´´©J°Ë#“/R¼ ]¦Æsl\G~NÉd²Ãty¶º¶/‰æ¾Äì† ©xð°Dßv›ììß1{üru0h‹óììUZ@¼?/⣠FÁѱz´ë z1u•‹„ j|r‹1“S¤¸eéc¦>‹:°²ËÒ¶sӇخ!|Œ$9GãÞö†‚ôOôÑ°&€„úmcíðÎ-ðÄŠP×ÙtšE+Õ®«‚FäZjî/äŠ;÷‹âWõƒ¥^óYn S:ù€ ©O{ÖéæãxSÓ­ÈÕü#ÁÒOÂùj (í´Ö32Øæsé…CE‘ÓŒ¨ÊŠOKCÁÂÔ93 z$¡Í¸{¤V{0tÚd¶Bóm1c·l?›ÆJ%i5ŠNÄGBÃ](4|rrCØ7>lžÝýù§®Q”ôô£hÌïœô2} y¾ yú±«ØgìÈ>é"…cM6­©ìLJl0çÚ0ŽF&„uMzÏ&#Sжúúë¿‘Á0éßYðŠhrôTÒ¢êl³Ù“™á/CpòY©©Ë‹Šûv¹ï[‰Æpé ã²â¬ÙÚ‡ÁSeçú´Ë’£“MµÜÕduí†i™æÇÆåÝï{±þøc­£)]~Ç»µÏ…Ö³ n„®J?‘é•Uò«¿W~ßðïm•ä8ðíËÓO`k¸çÁvÀ mÝa˜òÐñZ‘¶µù…Ì_1Ð8Ú•€ùÇÄ`Þ¡¡€ýÇêÖ½BØ«Œl¤+‡ØÄ-å­z}÷†€KûÐ3·{Ø`6\yXeÛßhО|«U·æ fµ4g8Š%§˜‚Êd2ÉIR$;Ù"¬42Úÿ´ô¤Ð‘~Tjý§êA©C¡}9¾ÁMÆÆÈ!e_ÈSD('ì4±'Â:;kV¸Ý¿Eð‹ù1ÑD‹PõÏ(O&ˆ†"éir41»)ö•Pž>;)Šâbÿ1Å‹ˆTpó~‚ˆÈO†AslÛî¦êX¯{)”ä–a(¼(´¡EF}ÃÄãLjĺÂgß4{®”à< —$›cþ¬/ãþòÉ•ãë5—<ù²+?6Âà{Œ0þÿ!Û̳ r T2Áph‚ãü7¸ƒÙFÑlh0I¶ZŽ¶<_]ý¤1uR endstream endobj 849 0 obj << /Length 3877 /Filter /FlateDecode >> stream xÚÍÙ’Û6òÝ_¡GM•EÁé>Û©©O ¤C!á“,8ø÷ šw }"Ôúh^uVdr$ÿ5€‚'„ñêû$ö2Σ\`¨öwÿø÷[š6Ó[G*ÎݬþXö Õís@/w}Óâ· QÝ™ŽFwVˆ ±åéû ä¶Ýã9qö/±Ž;cÏÆ#ŽŸH¯Z´"îã§^¬~¶kßÛÎìPÖX’˜W’Ù  xéHVDBs¢¡¥©@$`Ö;ÑjÍ~Ø‘~ûÜÁ¡Êãæü>T­9ƒØvÓS®„ÐZ"¥@3dÅ)Û6 }[Çñú[+S#üÎœàNv^[!¹ðŒ“…,•YäiT$#«¾a6‰UY,p ×,]%‘R|N8bÌ°2o^éh‚lq£iÇlµæ4œkâ¡g|`3*ÈË¥Zìh mÑ?I1 Éy—[‹XDÙ(`ß|ä)3ã£T+7åë (ÍGì £¯4ˆ1‡I$ódµCéý‡L£4Ó5M"k'ØòIÀ*ïùt`ê[@&“QúiP)|T¬gš_n*e”ÈÑê†â¶r2ËŒ%¶‰©™ÇÔ=ÈUÕßÑEä(Áô¤ ór.6ÿª ?–j²Û¾¬jê<—ï­dCwGØ·ŽÆªý’!Å};ìúÁšøÓ´MÇ0¡ãÇq”Iù)È®Sé“ôPpV©©È#*­~Ê{Öþ}à•£ÞúãQ‚¬e¤žðQx|´üPi%àu¡1Wfm›qø kˆtØl¼àçÏì4q_ëj±aÝì:ÑK‡úòÞÉV"ž¹@\ìð+: á>T4,E*¤¥~ך‰õ»EEéiâžT²Ça^(-Š¥›õaQ"F±<–LÏ­1 ÖE/C†DG±— ]Îd:VQ!.xîÍÓQ¦/œ¸¯š±­%!{ó>xœ"ÎV`kRvô9© ¢—íñÔN8MÈšÃÌb´TÎŽ® êHÜœê+âÝû4M®C¹Ò:Êåd‘Aïæ±Ó|g_³|ÉRŸèZ @0ÿÍçŠ,`牢ÊÅvÖzº°oËXwÍé)2v‹tÕm¹uŒIû(Ð ´UYß íÐú;Pòs÷:@H»SŒêˆ0x~‹à]€ ?ä› 0ÌÙ¤…!zÊL`$gÏ&èl'&¨é?yVv´/KãÆV'¼ù(³…“5oÝ ‹1•@‰ÊÓÇ”ø¯ÿ^%Ös%žë ê/jq ‚Î|Û€ÖÞ§Œ ±jÊûÞŽEReŸ‡…!‘Š¥÷iAÄçrõ —B<ãœË"°y–o¬Ä`a#`wòhnŒçcÔo[ª²@œesâ?r}j›´–'Œ¾ ;Áˆ³à,Àx5§å; MÂÃið2ƒOð(£¹|óí?¯ÄcªÐ1ç¶ Â 1ZEFÇV§1ÇðŽÐ™ž¾)ÁR~n¦&Ë›ÌL9dß:{ÈôæQ§ŸËö.™H}8V6SɼTFfz9ûS”Ob™_hx©kG=6¢€ßyš‹=.ÊU6Yµ]ßqæÄk†>XúX¡ãokbO†.—ØÛÂ,δõ¤\5[× t w”œÔÙD³¡A þ¶ªÍ|—ª;S›aš—€¡âj3–†l2QF!îùÉìƲ1BíoO• ­®?”æ<+kX"½ÈZ8kfem<uÌNîÇ ÙÁ‘ÚynNkNôÄ:cÊuÆŸ°Œi^_TßJ_,­@ÆvÅ‚X³=™3õ[*áxMì5È¡Üñ2Í·»ãÐÒ'jÔÉhàld£c$, Gv‹Å~DÃUí}-ÀXÎ?yû™cC pB!w¿RÝç~]‰Zƒ¶6So«?Ò˜]]Œ—= þgšUr_ÙöÕ8ãPöˆSÉ ºÒ˜ÉÓó~U ևƋíîYh{òNt€™Ð·TÊʃ³WUªmMw åT¡X;Þhw9„ÙF*¸B‹H–F(…=µ¬]×ù4äФù±dœàBk¸Ý—\º†ntœCï`• ÝmÜõÝ<,ÛéÌ–sŸÊöF UýzT†æ–óvO‰ü؉өçÅN)ÆËú"vÅób'. ‰ä5Y°òG šdž¯D:G·T£Ô·Ô[R§•7< = ô¼€AëÖÅÚ–&mLJ k}vyM=CÝÝÏËØþzŽp‰[íø ?®lͺ*Á0rA·®ð²:Yq3wMnÝ/ÄÉ`ïÕ|¿ €‘Ñ”VÊн„ʤ%@âú¤+‰9½ÀÛ2 aí¯¥µYQ°¹85v•´”œv@p¸;òýŒ§ αš‚ Ò»Œl‹•ç\“ûµ¸ƒfº•Lj\)6"ãJ¤)E+ØE¦G`õ•n™yæzwà?ÚÚtƒúÀãGŽx±¶@3›$ÒðFöB{|¶¤ŽmÍ©©o¬%²˜4‹%DñÀOe×G)K!pQ CRE™«D}ÊtA—S½¨Nˆ•ˆ”KBa‚›cŒ)e(9‘ëÕ&dZáŽ2 nbzìó°¸ÍðÔLúe÷ïyP$ –š”ñ5ñ4tRB ÷jÇ žµãj~󋨑WÞ¿šÐE^Ǽi¿ÆwKrþ\çK…Žgy›Á85ˆÊÌò¥Q6˜ñhÚ± î„~/´—xé×áï |*±ÞÎQ¿Ÿ7HÉÿ—#ÝãˆÙUÒbk¨ÙU -ƒAì<´ÍyTº§Ž—FÐÿÐÂ-{û -£A2¤½Ê ïiÜx醻ñ vÿoü· îÅ™…îßpâs†¹\7Cú]š}/o‡¼:ÃR˜Ê ¿æ÷4 óÝõ‹ÿŒxnÙ endstream endobj 876 0 obj << /Length 3536 /Filter /FlateDecode >> stream xÚíZKsÛF¾çW°öDU…c̯lå`ÇÖV¶œl"ËÙƒ“DŽDT@‚ €±•_¿ÝÓ=xqdQYUª¶*q0˜GOO÷×_7-îÑâ_D³ßW×_¼¸ŒÕ"y’˜ÅõíBêTÄ™Z$Y,¤–‹ëÍâÃòçH¦¿\ÿ³Ÿ÷â2‰F“r˜’à 7ø]]ýf/V*Ž–Ý–ëzw¨lÇOí}Ûٵ˽Ú\ètiýÎZÜòÅ¥ÎÇâ-d$ý^_Ñ ä‰JpÄ*Í…ÑÙb%¥Heì  Íx5%4 YeB%9|KÃT¶ˆEž¦nÉDèÔ,V‘Èó„FI-Ò"M²`,£„Jý{^ Ž&gRêÅh›( óJ%ÂD9œÆO’Z=—Ôf*µ‘ÉXêoO/%*K~`m#úb%cóÐÝ()d6½›÷ñ2!MzÖÝèGN™äSJ3>æŸ% ˜ÊJǘd±Bë‡E3›Þ1OïE¦"ÿzôbäübÌäb>ÎÃ’A§™,¶âa£sœ·˜ ™Ôj¡"7v8KÀÑR¡`•Ô"ÍùØ_‡ÖKAˆñ 4€‘›À!´ÈMþ¸FxØH#ç-ö$Œ|‚¯I"àŒSÕüÅ‘TðWNf‚¤`7ŒÄ…²°—eÓv â Êý]¤sαÑ2Øî™0Z“>ÒçÆ(Œé3´> ¤ÿgø22}”~ îòë—GbÊ%Þ2¯ìæ¸îÊzÿb]ï7vßø@xrØ-§Š(/ È E¼hpuÿp…Û˜é6pž¸ßçÛo¾¿~‹«¨ää83ãH$ý¼¯ié'ÍSÕ ”f&™*h0ª)/¸†,ùóò/>¬t¤—oþsdèÈйå2ÆÜ€uáFêå¥_äc2^Ú ­ÐÂtÛu@Ñž¨?“ Ëóô7Ñ L42ë(¿Adº,ö’Ð °Qî!Tìì¦,:p‡\Š8Šý:÷íÄ¥=XÒ©×]ÝÐê˪¢ûPy QKO/õ¥LìªÇÎn¾ÄÇ"¯Š–ÇŽê}uO£ºmPB§Οä«SB.t,Çf|ܾlI Æ]æ±ÙãíbGWò¹Æ±µÍE/*!_~_wÖ(º€pÇ,{ž3Œ@"ÇËøÀž¥··¶iHô¸½hù–âLd2ã[bê‹K â„Ýx”°L9šònÛ­¶`[«¶ÜX1ã+Œ5+€éìnyNçø™ÆYòµÇõ–dx 8BlLzëy¬ì¨dÆëCÄð5š$ç]m¨4þŒAå¨Øã§Åt¿™šàT6‰é?GQº'‘%éÕ¤žOMê WÎ@KwnGôpê¨õÁÞó±F%ž/+Â9D¼D+&pØál”[®+[Šõ¯Å¿‡èÖ3T ™Ù3xy 65¹Ïœi{<+Q|xh!TЋÌ}üIB4+ü&ú[©Òn¬lŒoâ»÷ßýŠk*wÙ*ŸªíÈ"uº^)/7G$ËVµ'ÈÐVT¼ÖÆ}ôÝOO0!F¨ä¤Ah§@ìÐÔ%~NÛN`ÆŸY¡û3$©}œÄ3üœH<)‰œåªSN ØK€·aå‚F®Ù8»PÞ8©Å]ž¿¨„EÞÙ=Y×ÇjCÍë»öHà);€gä„îwOKØéü="NÕˆ)àÎõL—_2wá®›ª^ÿê#´03æçL²¦‚~6µ3Uj[7‡Q¸¥b½cFÝ«¨ÅÏXq2”ûX-¸6œw¡¼Þ‘Wÿ®¦ß>Ó÷S\œ…œóÄÑѱ„…Ø»ó«qAF"Kgn×S¿Aïøj¿gJxÜ»²Máøv‚ 'iAaôÉc̶ná`În’žÊôö‰¢å+wn©·5Êù‘®Šý¯Û{õöŠYð±êÊ[ðê ,´+*dÂKOUá !å`^¬(eتܕûÂ:ª©ÙÇUCûCÏ­-QèíZEÅC[zÃhlÁü=òÖ¥lôxAŸ\J‚}ŽYGÙ²=pC#¶ð¸)HöiH« oàÌÛ‰ìî²åhz]ESÄmSóÿ]Š¦+½¢6å-Ê )8\cßk¹ÜÔòjðï8Ó¾­9¡#lS¢aŒÓcB Á"à]ßa³vx–d¨’Ú,1Äg[UˆÚ~×ÔñîÖƾ>=ô¾Ñv~xý¦eãžmháýW¾±.‚wí–n”Ž¦dˆ 8ÓÛʃ8BF¤Óõšêî¿‚ü5‘Ëx>÷bc1¹:ŽN4 <ÔjSwèT4È¡UKm—ͦŽ¶” u1Âbs@Ø–†Q]×°ôëÐêS ©¤ßóæ>dJSGй;Öh[`$©IgIŒx™'À§Ë® ~upNl+OHüœÃvpNë:?nKÇÄ¡9NQ[éðn<µWË°õ­wÍ«¨B‡ÚÙb¢ 4J{ÞŸå#¥íè,cÍeŒ¼Y6æ9ÙÀ á…øzŽUÑ ¹¬~ºRJyöëYà€ñhï~zMƉc\ÉÅ ÉŽˆ¸º²ƒZrã¤rùãþ†tx]]ýè0TÐÈkOð®±-â)­„õ5€ÄväÐ0¤öžÖÒ˜‚ºÛãMÛÞùR®ÍM¦ŽÁÊ îbW;Ô[j~û8˜Œ 4fv€ƒ­Ýf]ö>º“ß·ôD5EÀJ~u³ã áž`™{zrlÒAžï5õ¹Ê" RÝÙ›¦à9°™ˆ˜‹”ïF—Óx`JŠem‰&mUgˆ= B„¸ˆž›ùÌñ@³($|QOиªËÎÏa¸Ãž>:‡@ùßYä„‘z.žT ¶¼£b3¼/觭Wàf•ïõ‘†¿%ì ~ŽäКFrèÀ»qñæàËÖ²˜6cåè76Ü·‘¥ž}ýXþ2¬ç”¿Î‘úp÷–½É¹½ëîÐ Ez½ÉÇD’  ¾3tM¢»â莿Ä{3ÏX<[QãèÞéû$/ ^Øö”Ö¯ÚñW¦Æîž•3`Ïš‰°¶Œ8Á¿cZW= ¶ÀÑmwZÉK¸,b DN2ïë¥>”{œ¶°EÛÉÁ±s¦Bœxׇ-B²qЂ]=aÁ)PÃ1h08ίÛPíw3ÚSù©ÖäsPhÜ+ü´ƒÍö¸Û9p‡öoh¿@¦0ŠµX2@¸³<ç²¼C÷{ü+Œ«£ô-–QßÐåâoA? >N:¯9|è¥I¹’Ö㛫‹' “k®–Ê0†ÓÜI#‘kæÝß¼¢¶Ë~Œ/¡»—‘ºëólìqŸÙ\k¸ zvJ÷† أ౞ºÀÚýùP 'VYuôXt³¬_ÛéŽß9ß( Ç(f.žxžÖ1L­xÙRîHH¾áž}®1àœ“·£mcöí‡ä¤ê)þöwNÓnî¹»ØÛŠ‡„#o[þng_ ‡. ‡ŽGá cz‚ƒMðwÄíg+Tö–¾»ù7î… }º~?Ñ[oå}÷*j£oú<ÌPeæòjXñTM3;ûІ- *¨&j:'Ò†+ApÌŽ‡ ÆÇÊ¢z¸NM¿ÞI¡yyª¹d¹Èd_syHHs¡’¾÷@a>¹Q³Šêô›C$T_ý4B’õüXÓu¬ëŠËqxzti­§€„Ÿ×Dý \÷Áõé&Œ§¯·¡R×£¤;Øa1ºGš¼X £|’AœiÄjJ°c¶yýhyﲉL–×:^!_?DñÝW!» ù`žMˆ4nžŽÖLƒ`ˆóÇÜÕŽðqÜYJG\o·hÜÖÕfXoô5Ú¾m=6VF;Æó1žñ|Œçc<ãùv¼O–<á[­_\¿¹šž¿}þ¯ÕúË‹Ëw›ËiiéõúëoÖ_½ÊÓ•ñZ„CŒ «õ˜Ûäõ¢ñP÷(b{2YË‹°þýÅË‹°~>ûæ«?½üöûÏrþþóϹ%‹à€ùFÃY)Ý"ÌμD†ƒšðÜõ±%`ÕÑq”Jh¡£•(8œ8ý“@Ê¢@šG8ô ˆ(Qúi ¯ß|ÄËï/ΣƲ-­ f”•¡»BßU*žK{8¥äš£àÂEaôÎ9Va”¨ú@Z1Ê4g'j±Ñ‰yŠ&·oŽ-h(Ã@¨3œY:aé+Ik~@•h 8j …ž#"¹b«J–S8ú’0ÀK"(Ö 0(ìÌI;Ó„«là/*-ŒC«Doe<{¾ K‰Y–c%cÒzÆºÇ ~p Ìæ?×g”uAC-™u, \Ù=6²i‹p÷3´’ÔJJ‘äu‡…Ö:~ÌžVì´_a4Ùkìtq°cÐæÛ 7ßÇÁßVMDÁæ&-Ç&íE`ž¡g‡DH `¾3‘lÐÓðŠièÄ+ÿò׿!»‹Š´ !å9¿þðáõ19úI° YÂEÌEæ |§"÷™%¬pô Z8KX°“Ì£f gÄw/3G¦¿Gbu ûszq@õýAFpÀû÷¨þ'YÄA~rl¤18Àeðï;æ ž‘+0k¾c®Ð·\éÿ¶Í£•Ñêhm´e´u´m´>ÚE¹¿ew‘‰)°naÅcBjà6’Ýã î¿hÀVœdh€92ã7Òä Öðs?ê÷ö]œß’Çèpƒæ‚°D‡lä–œxîù„ZMD´Â嶟aXB""s`üÆÝI!ïÃÁuÆGÌÊÝ©c ªI‘Ÿýz^ööýÕ&ž½Û|x”Ü–\¨–ðÀXÞjD€€`ýå~öäù‚v‘pL²ß`Í'jY˜G1CÄÖÀ0:\mîç‘Ók½…˜¥(¥Þ ÿPÖV ùµO_‹,˜© ãÈ[@)µÅjvÅ^œÙŽ`—'æs ºzžÇIän8 fêzZXjÃÎLqwª®ÌYxÔ“ÏÎ5Å.zŒ Ì,6ò„£ÅÂjpHö¹ÅO¸+ØŽuÀ¤Þ‘ ÐP¦(.ƒ È`2Ø€ 6 ƒ HY2Ú3¼vVÔà¾X+ÖR‘Iy¨p_–Â] ®¶mÀà¯0ñI÷ê?uâ?mª9‘éô (kŽ°¯—,éËÑ„ä^àBíHϫ—,Ÿˆ,ZƃWgªW‘—!ÌåFwPYr{ÀÔOÉKY[ã¾ÀG˜(ãÊT’i|ÐRŽ€u±¦÷,]&夒¨,²©î=¨´y_î&¯d] ‰Â,aí$Ñ3…¥À¤k9æÃçæ`>üà*è¨Cçí^Zì¾Ç­ÿÂk[»«×Öá•uxe9šŽMGŽ¦#GÓáåmxy^Þ†—·1žñlŒguÑÜNÉDúÿíl*²æ_&Î+gø‡ÄZNMÙz,v<‡xöϧ¿{ñí“ïþüÝ“¿§¾ ¸´Þ·xX e‰­—Ûñ\^\o®ý6¯ÿ GR“ö43qøÛ‘ »º¼¼~´hÊP ηUøó©X BÃH.{òNÓ¢‰/wƒ…û©`Íû„Ž]‚ ׌tÇO DˆKN‘Ÿ™ìò‹ÂÉ<$KÖ©wQÙ¤“› ¥È+hÓëÌÜSã’– ‹Í…:Ž@»¥È”RŒzäÚé¾Qa­~ ÓO|¡ÔPÎÞ}¸|Æ·àM)Y¸IPø]~Y¤ZcƒëWøÝvË…ú¢×`fÜé‚TKÊà/&¬Zfø[öêI@°3N2•³C6eý4·­‹Þ©c4å©Î]*Ý-vZböZŽäëG€D™Ï£qûr7y{ޒړ šJCN›'k:-ì8àðÊvŸ‡T;PovŸÜŸ¸!ƒÌ¿‘òs¯rS×ó+7_úð{+½•Fÿnèx)`Ÿ`ÐнòÃ]Ùf«¿`›[xwa›u°Å:Øbl±¶X[¬ƒ}ÖÁ>ë`Ÿu°Ï6ØçÐÚR_ µìdúêAS—Úšç‘Rý½œc~Z`XzÖ€UaÆ `‰Àn Ì‹0NÐ óõJFwÊýø6ͬ9‚¤¸ýœ5ã³á1? %3éB×âSED×'¼mê-?^á›ê”wœ~ÄĬ‹ÀRÖûòéJEb¡¾E!8ê$}ª“[o'øÉÙ›7~|´,?o,¬×âÈfš 0©LUžc\é︾Ü,yŦ`³¬=f²W~? ›-,äó[³Ba Þ >¹—è<)ÈJÉî3¯3’Ï HK~aº–”Ÿ)Ç>‘Å‚¨Æk ë³µÁ¸=¾F½•’ìËIæŸñ+íÈëóÓ„–edú·ª·³ÚÀD¿ÐêNËÞÔ·¶Ádž°5ÞÏ™”¸í“ÿ> stream xÚ­ZÛrÛF}×WðmÁ*Á\äm-ÛYmÙ‰£Ke7Z?@$(¡ Æ‘¿~OO@9V¹L æÒÓÓ×ÓE“ûI4ùá,òÏ××gß½Sé$ Skõäz9Ò„Ò¨‰ML(”˜\/&·A[Mg2VÁv³ÈÚœÚ:hrû‡–ûʪú­Xßsÿ&«}wµä¿DËz*‚jÝf%¿¯²¶.þäIÿ‹Lt_çSa‚G-Ö»‘;üúÏCYËCY·ÿTšàs^sï¼jÚnçlíWpÇr[–³:[ÿƽëª^™O×ÿ†Xf" S“òÑùÈát¦… Þë¬,‰­”ÿäG›¯6UÕ~´©Êm[T´kbëM±žç<øÙ??×Uˇl*£à:|Î+óvo›×ï/7ÐÁæ!kr/¬Ê³ùx‘ðYGÎwWVsA  =M°ÈçÕjSçM“/xä.ã9º [ >§Lj,khú„ŒL×LÇâØ9«‹ üØÔù2¯ëŽ84$Oð÷Ý; ÌQZ ¦³ï®ÎoxҞ͒ÉjÛMºËçÙ¶ñÌ‘éñžÛª^yðYœ@f2¡²v_.Ÿ 'BÕ&¯3uÃïYsýK„^IÉïHuÙ¼­êâ‹[óŠÇ®ª’µêßϽ„ýë³2Ò_H<õþyø|{}&Ј&b"” ãXLL$B¡“É|uöûY¨¤ÊÍ4ÝP·Îw|w±“7ÕÙÏøדLÓ0Mt·â«ˆÉCb3E 3™ 8ìâ ö±Òºx£hPMt’†"U,|’dæ­ÒyGÎzÉÎÚÉùr7¼ÉÖyÉÍåTD{⇦­_r·[ñž‚_êžð€Pçì`¤ôµ×²C-ÁrÀ|ÔâP‰Økq¿í,E|?Yxökö6ê*Çy9³Á¥®ó#^»±ŒeÝ”º-²òYtýZçËÝŽÊãyè6Œ5_!iðñ™ê((Ú§0åœß"\äYëäBÝn>|¼âæ6¤QzãülŸÚÖíÊK:ºÐØt»qV·^°>顱ÊÛ‡jÁí9§ô8 °,¶.¹âµ_•5«M[o¿>]:`ñgÑ>rCÞjD«mÙ;§#zDÚ“iì…%pG¼w®sÇ)^P\RhxW¯0ÕÙ4+†´DfÁ¨\ŒéÌiA }`Ôá  Ä"göqºNFG‡ª¦!Š¨Yt´0-«³»Ò¯f4§»À†Vu×fÅšÑÎFfà²^°;3˜à°ŠÉ¤Ó¬mÆÔl ‹E¦ $ŒmÚÀ!ß"(FÑ\&ŒT7±S<© …ÔÖä¼Ë¡OÅG>E¬¸ KáÑÀ‚ä·êœ?öΩ>é¹åk?V­]Y‹.|I»~½r¦U§é¾XXE›ÒËØ%ó»ëÜUxì:ßÖä_n3—Q\¹A§*JR"'‚‘,øË4‰ˆ˜&ßæaêȺþ¼,V¨‘¨¢æ f¥}¬ÐÎa‰!j-·ë9…ѬtVƃd:Ôê&­p8bYëÈen˜P—¼µ&6vz*¥“Å"•¸À'Q†yGrÍ¡Hv¥­$ÿ€¼²yW‹J_ʧì`^<Œ£•CDÒp_—£9¾G!b~h8üw/.¸ÉWÛ»&ŸÓI«¡ ùQràäˆ#{ ÑÔƒ:’¹š;FÃEáÐedìbî„éáI‡£ÐEµ ËqY½à!Ôrþº†³`3Ù!3¾ÜÄ”yY59i—:aAY˸Çã>G­›»Âì@Å0$»4ò$¨µg¤Ô10ÒW$ÉÎ1´ÊWU7m¿"H½KáÉž{~Š¬ì3¹ ®Ž6l•³õ+ʬžŠ$¸÷ÛÝOÉמ.'é”2g ÏÆÝh‚ÞÅXçìÜC0«fçŸ(Úb•Ô9}ÕÛD[—–Ÿ†—GèòÕɹŽ”ýÊùú…൜*m%ExHÅgd4KGO!,Èþ¦qï$Ù,³ùá¡3¯¯¨‹‡¾<#-U°ÝuÞŒ$l'£cgsœ]NT»¨j ?’`6X%>>;HÐä«|îý ÄÒÙtù”G=3:8÷ù{¸5E²O™2¦xÅ€@Õº,¿mrO¾Xî²³½«YNcVºq‹´¦Ú>¬Ñ®6qT8.A•ÃûŸËUÜ%ëÛ«7ç¿~âüy¬ƒ"ã(k¶óð!ü w¤L˜Æ±õW,*'*L"OGî9üÁÎHú64Q ÅjãdXÒ‹ô0òHÄ7—ÏDWL¡Ñd+ßrQd0–>^Ì–uîÇ÷pu<ê`²‡:~q¨Pˆ1œCw¥°^•‡œRnF¼nûý¾€é›Ów:ð)Ü•Å*W]*…\žç~ÀÝÂà9GéwŸ/èr['Ú•/)ÝpænšgX@¹A1Q­äᔡS!O\m©¦ë7Ud¥ÝÜ_zn‡Ä1Ãà±ëüºÊ.ÉêÆgo µ~¼ñïM•>/àZÀØMí*ŒU¶ðUÄLÀÓ(»UòŒ0äÆK“ÿ¾Í×]>f{óG‹ÈðÙ3ù槛×ïߢàCŠÿxùöüâêâ§GØM’PíB×¾Í:Æ»›ÙÊ_ÆfMÇOéq~ó}7p¶X%Î×ÒTbœ¥¥Ú»ÚÅÔˆàÇ©‘ȸh½§Ÿz}C­·=;2 ui¬;þþÐð·"ì"ƒ =ømÉ7]!;UÅ2Á‚Î<ÍYŒ®ãK#Ã0…`ö„ ¶üXqç†ßšñ” ÁI˜§#k”ʣкãŠrBœ0)RZyç–ù¨÷˜£[ÀÄŽ m2³IhR1M³’*Çd+CXÓ¨d¯Y”hýз.Ç%«TŸª¾§Øeè‘ Š½ Ë+,…î>­£p¤`¤ö!Ø\ÿ|¤Ö˜F)¯IÓíKÁz:‹²| Ÿ›¾õ‘~Æ’;|P¥Ðg(éoÒd„ÊVjGJG^“W´ï5ý\z†,A×Øå1ÁφK-_â”H߆&bÔ c¤8}æcZ-ö™ß¸í3÷[沈=6P”PÉ2Öõ$fà8Ší#;|ƒeb‚˜ˆà&’}DÂ]¨Ý§*Löîv¤q_Èäûì‘R}Ë™µ Ä;RŠKìSÉb7×èÐƽ­»‹UwŸ‚ý†ÕÈŠ¤Û[ê›SÄe&wÐÿ˜þêw¿z!:¿ž¢£›z¹Tõ$Œ£¹Ÿ?É”4$³yU×y³¡O@.}²ìÜÐ0_î¨Ä ±gúòí?ßlEŸ0eòì£û¤ë¢§J j"ÿ¥¡¶¾æ>NÄB(lvcl+Ê]ÿôáãû·ÿs 1÷óÔ“‡WcXá4]Lê @Ÿë­ûRÒlöowI-]A!ÓÄ6¸*V€£uù8Æ |¥ŸUAiH*‰ …F¦žŽS*G%Ô@æ2…¬ˆ”MõX µgv2êÝÀù(2«ñŸ_ŒJ‚¼pߎG·è0$ÉÆ`ýí ¢V3"ž¤@2ù–ãÑŸ¤QB”¤Lÿât@iâ)ë#¡‡œÖ&“¼ë)¬Í¼ç»o ç§êr õ¾ã@Æ5ý ÎÝç­Ñ¸(°ëÎõ=q'ŠÌKŽI¨õWÎþ)Ì©¨C§}Þzò¶A ºD0/pM_¶ ¼áYüeÃXðr4Ä<–¤¢Ý…ZsŠÿ$mò"ü§ ržÉ?€Llžò†™†ÆäAbZœ8F‹@*«_"RÜEÀo9¬.é'ÌO±Ÿ¢„QÉ °/JSˆÿ™ìCë6þ ¨cUŸL¾œà_RÚHÓ—à?I¿Fú}2~âov±FuŸû¾`,¯é!Äÿ?I´¶ endstream endobj 872 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figs/BLRLU_step1.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 909 0 R /BBox [0 0 457.725006 422.008942] /Group 900 0 R /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> /s5 910 0 R /s8 911 0 R >>/XObject << /x6 912 0 R /x9 913 0 R >>/Font << /f-0-0 914 0 R/f-1-0 915 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 918 0 R >> >> >> stream xœ+ä2T0B©k giih`j¡œË¥Ÿh ^¬ _ah¬à’Ïȵð endstream endobj 913 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 919 0 R >> >> >> stream xœ+ä2T0B©k giih`j¡œË¥Ÿh ^¬ _ah¦à’Ïȵ.ó endstream endobj 918 0 obj << /Length 926 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 140 2 220 238] /Resources 927 0 R >> stream xœ ʱ€ À>SüŒŸ@ Ã,”ZÝÿ=©®¹G¨ƒ%{5œË Ö4¼ûIÌOJ#¬íæb³Ú´ûn9äöÛo endstream endobj 919 0 obj << /Length 928 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 58 0 458 399] /Resources 929 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 921 0 obj << /Length 931 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 923 0 obj << /Length 933 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 924 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 925 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 930 0 obj << /Length 934 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 932 0 obj << /Length 935 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 873 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figs/BLRLU_step2.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 936 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 937 0 R /s8 938 0 R /s10 939 0 R /s12 940 0 R /s14 941 0 R /s16 942 0 R /s18 943 0 R /s20 944 0 R /s22 945 0 R /s24 946 0 R /s26 947 0 R /s28 948 0 R /s31 949 0 R /s33 950 0 R /s35 951 0 R >>/XObject << /x6 952 0 R /x9 953 0 R /x11 954 0 R /x13 955 0 R /x15 956 0 R /x17 957 0 R /x19 958 0 R /x21 959 0 R /x23 960 0 R /x25 961 0 R /x27 962 0 R /x29 963 0 R /x32 964 0 R /x34 965 0 R /x36 966 0 R >>/Font << /f-0-0 967 0 R/f-1-0 968 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 984 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úÆ– .ù\\¶Ü  endstream endobj 953 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 985 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú&F .ù\\¶³  endstream endobj 954 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 986 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú&¦ .ù\\¶È  endstream endobj 955 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 987 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú& .ù\\¶Ý  endstream endobj 956 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 988 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú¦† .ù\\¶´  endstream endobj 957 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 989 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú¦& .ù\\¶É  endstream endobj 958 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 990 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú¦æ .ù\\¶Þ  endstream endobj 959 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 991 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úf .ù\\¶µ  endstream endobj 960 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 992 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úfÆ .ù\\¶Ê  endstream endobj 961 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 993 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úff .ù\\¶ß  endstream endobj 962 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 994 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úf– .ù\\¶ô endstream endobj 963 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 995 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úæF .ù\\¶Ë  endstream endobj 964 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 996 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úæ¦ .ù\\¶à  endstream endobj 965 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 997 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úæ .ù\\¶õ endstream endobj 966 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 998 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú† .ù\\¶Ì  endstream endobj 984 0 obj << /Length 1018 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 140 3 220 239] /Resources 1019 0 R >> stream xœ+ä2TÁ¢týD…ôb.C#c =3cs ]#c=3S3…¢T…4®@.h k endstream endobj 985 0 obj << /Length 1020 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 58 1 458 400] /Resources 1021 0 R >> stream xœ‹1 €0û{Å~Àx!‰æ^ ÑR,DE,¢…ß7 Ë2ÅìFbäŒê•q¾¤•xv­Á—TŸzѼ€c'‹º<ª ËŒí&'J¬K#ñF¥E²<& ô­dÜ endstream endobj 986 0 obj << /Length 1022 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 227 245 237 304] /Resources 1023 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.## Ks=c3c S3…¢T…`…@®@.A¡3 endstream endobj 987 0 obj << /Length 1024 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 243 301 293 312] /Resources 1025 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.# K=c3c  …¢T…`…@®@.A¢3 endstream endobj 988 0 obj << /Length 1026 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 147 165 157 224] /Resources 1027 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C Css=c3c S3…¢T…`…@®@.S›c endstream endobj 989 0 obj << /Length 1028 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 163 221 213 232] /Resources 1029 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C3C3K=c3c  …¢T…`…@®@.Sšc endstream endobj 990 0 obj << /Length 1030 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 147 85 157 144] /Resources 1031 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C #Ss=c3c S3…¢T…`…@®@.S‡b endstream endobj 991 0 obj << /Length 1032 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 163 141 213 152] /Resources 1033 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C3#K=c3c  …¢T…`…@®@.S†b endstream endobj 992 0 obj << /Length 1034 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 307 245 317 304] /Resources 1035 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.c Ks=c3c S3…¢T…`…@®@.AŠ2 endstream endobj 993 0 obj << /Length 1036 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 323 301 373 312] /Resources 1037 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.c# K=c3c  …¢T…`…@®@.A‹2 endstream endobj 994 0 obj << /Length 1038 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 387 245 397 304] /Resources 1039 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.c Ks=c3c S3…¢T…`…@®@.BJ: endstream endobj 995 0 obj << /Length 1040 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 403 301 453 312] /Resources 1041 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\. K=c3c  …¢T…`…@®@.At1 endstream endobj 996 0 obj << /Length 1042 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 147 5 157 64] /Resources 1043 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C ccs=c3c S3…¢T…`…@®@.Ssa endstream endobj 997 0 obj << /Length 1044 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 163 61 213 72] /Resources 1045 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C3c#K=c3c  …¢T…`…@®@.Sra endstream endobj 998 0 obj << /Length 1046 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 220 0 458 239] /Resources 1047 0 R >> stream xœ+ä2Ð3Q€á¢týD…ôb. r [šY*”ż€8‹+:(j Âe¢à«P¨`Vª ¢L ’s¹ŒŒ€†Y(šé™*›é™[šƒiSSK…¢T'-…@®@.YO endstream endobj 1000 0 obj << /Length 1049 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 1002 0 obj << /Length 1051 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 1003 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 1004 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 1005 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 1006 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 1007 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 1008 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 1009 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 1010 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 1011 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 1012 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 1013 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 1014 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 1015 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 1016 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 1017 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 1048 0 obj << /Length 1052 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 1050 0 obj << /Length 1053 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 885 0 obj << /Type /ObjStm /N 100 /First 924 /Length 1824 /Filter /FlateDecode >> stream xÚÝY[OK~ß_ÑCOWßÛQ4ðŠ> ËsβCfgÏѾêÙÑ…DO0vuwÝ«ºº¶‡¬JÄ`…u"¦ ´N"©$¬!‘H g-F^9ŒVxï1v¼î R%­YDÒZ÷ pb4 ÖQPbö¼0¡l àl,Qð6¥dFI)xÅ ­D@Œ¦ÀTj3C“X-’UB¡–„¶P;Y @ Ö< Ó.…Q‚åÚ;p¶àæXp¬çÉ‚sRàìÀ9ypv$ŒÒàì€Î> c¯$a‚§Q‚r&* g>Aˆ a’fÀð 8aUFö2r‘£°”‘bÎPÎjFƶՌ5F†¯­aäÄQgb®ÖAERNá„ÝHˆ’BÌl„C/‚= pKÊóšaˆ)`¬å°r e /œR™K`ˆe ¾NÁO€Cˆ©2È$…è"á 2ŒdYˆe îŽË@à± ËiË2q@,!wC‰!– ;cXüáŒe s&² ÄË@àåS`å8[A†,±”)ÀÙqj*ÄËuš!æ³LjS@1‚Ò#û"òÖEX!Îq6DhêI1€“¤‘Uxž‹PÝ;Í+ùp<9áCJ£FŦØH %vDñöÝ{Ž¥4PÖ/ÙYÓùdòqôðaFÞj¦xð@[PÓãLf²-œBÓú‰á ¢Å„«ÙÃ,«ÑOØ`–$ G–.Ðx²¤‡_lXr†û‘¤Ë ò‡z(W¼l›ñnÕ‰}Q¼ÜÜÅ^õ¹_õÞûrZa£<ªFÅ#ØPM»Ü•;Õ¬™·ãŠ—|¿ô¼:¬Ëæ³Øgí=¤†¤?BLÙ‚õkAú¤m槂KGž®O§ 8ï Ž«Æ!ëǸS?&µi1êÅh£]Œ}h¾Zò¨­Ê®iÅqY· IF’øpç¸ëNïE^=jËÓãz<“M{ôáîÝìœÃù¸ú9ªo\÷øs÷d·+;øo÷y9û;Wælò¸µÖùÿõg»âS9™UׇÁÄœr ›tyº×Î+Þå¬ÊùXl¿x³ó~ãÞ«ƒù´›¯m×GǠتÛY÷è¸l…Ñ£b»\L¢ë³x³šÛú”]ÉWJÖæñtÜÖÓ#Q¼©§ëÓY½\aá°;æÀª[úsJ_XóQ!åöšWÓzT‚«9+ú³þÙ}¼³³ñîÞfõWùz¾[NgWz‡´¾Ä=z¸{LŽìU?ÞýÖt/|>Ÿ\ ÜyG¹ó<<×4c4ör^¤3—P=-ùé2ÿ”¡”KϵKåærfxc–²¯Ùï‚b.…³AÅúäô¸D™š†æ.ñY@ú½(Oª«2Û[åI=ù"îô;"ï lMÊ£Y9#mä'Ö.]#”>ãøVw>ëÊI=^ŸM*¡p8gã\÷˜”UáÉÅ„Ã[ž>­˜=˜®:y-¢ê¡§Ê Õ“ ÍM 5ï²Ä=g\¿.xãjÛ¸ùX³9á8 BËxµu:ž³íÝyë˜òzóôÒ¼ ³…_KŸàY©òÐ×»\û€ÙÿõûshGGhGZ…0r–Â9æ[)'Ö^ çœò¥5þ³E‡ò~ØÙ¬þ©ÇÕΓßîfñi…›%¨Uˆib½ ±Y…Ø®BìV!^¥ a⸠ñ*WÉ°¸J†ÅU2,šß©åJéÏh¹P–Õ/õ\o_ì¾ÙÜÖsÑÿäÔ¿QÓõÞ€†k‰wÖlµ\}ÁR_Û¬ MÖ÷!ÐCZ'à™xv žˆçâ…xq ^†Gj  Ä ÿç^›”?cßeëwn¶‰_ö9{ËÝv ·Œÿpüð‡ãß²ˆ~áçN±ÿygz¨³3œ_ÏõÛõµm£i«6¿WªÅÓâYñ”ôüÂ9îľZZÏÏù^†üÖn$?£+câB´žßvQ$Ÿ4{ ~"âW]ÝUòߪžTã¿«ö>™»¢Wpuu´¶2$þðàdÀÝ“¥æïDÚÈd¯V§<˜œÜ'psše¤öüu¡j•0¿6K´ì·«JîÎT J*ë1âO$:I½̯ñÚ_£Ùü`Úº™J'ÉÝ [¬’ÎG¡““—¥±Aò·Þ]þZ·ŒoR•$ùû«B.áöôRQÖÄä‡ùkRÝ &.JÑÙ)h€·’ÊPºœœ4PçæÒE#D6Yþ)ùs’^rĦWée®¤LZø@£ÛÓ„l5‹OÒ'Ì’É]~~ž~jšâ*©oP£%ÍÒ*Jâ/¡‰0gÅ"N]w| ÎÚR™ÿ׉…­ endstream endobj 1062 0 obj << /Length 2058 /Filter /FlateDecode >> stream xÚ½Y[sÛ6~÷¯à>ì„š©ÜîLZ'é8“¤ÝØyIšZ¢-M%J%©ºé¯ßï$%ÊTœÖž}0à9ç;wÈ<¹MxòÓoǯΞ¿RYbYæ”O®na$Xð† %’«yò)e“©´2 Ãç«×Ï_iyðÕT2e|2uX‰ßœOœM˜8“¾¡Ù›øÑ€•,³ r„ÞN¦N§¿à©Ò :}öòêì÷3}žˆDx˄щuŽ)›ÌÖgŸ>ódŽ½× g*óÉ]8¹N$ã™Äl•\žýw ¡÷ÌÙ@HØáE`þ®eNó+€å.ý•>™ ãiYšô%ž:}ß=iGÉ›L•eÆ*aDqÉT0iã¡–ùz2õ2Ý…'ÍEº ózD N3Gh¬`0Àc´øš‹@IÊ(Hd›‡g5Q&ý÷D‘¾žLMúódjÓñðï\{¾ÇÕ¢ &¶ü€ ÄUBw&þ(;Ÿ^Òç:-h0iCˆ5ÀNm–nÂsžØwÞ’8BxȆÛ8ìâ°¦ÁJx+ãÐĽ‰oZaïM|3颗ÀE°Ï#îÓY|û-¾åñí6¾dw™þ‡ˆÉHÌGbž8[z+Fü$8sÞzÈ?±½QL›'±=(IsÚöðx}†XÆã©€Â"C0O…ò]lHŸ*² aáû8Øor ã‘]4r°§—Ñ"˜Ž†u¶‹2š\DÝ[‡à2ÚE¤7§@Ú{F§  ¾çöŸa EF°ÙWŒ0õ–rYC‡]fƒ½ÝàȨJi˜tÙ)êIr;<]øÎÊ/àKžžú9e{š#ÈΛ¼84‡xÈRf(S&±Ê1óÇ…T‚9œ'R]á;¶‡0ÙÞeÌrÿÿÐ%3â NjEuþ;Z' SÜ%_›=®P:æ(M€”jÅ}¸_îïÂü‡ð|ÓÊCóáù’üð¸€êP@Íxí»’n òx4 VåiÌ!ÿT@ƽ@0ÊÆÉ‘6Í¢h§yµlë¢YÎêïZCðZOv:¯wëí˜{9Áª£åšY¥¾®L({ Ë?éó"RÒ ØÖMµ›±Eoòýqm·}øÔ‹Ín5¸®‹8VÅv•ÏŠnõËFÄS:ë©œ©g\Û'©-¢^Ùo‰@³¦oÌJSµ DJËp6œœ"ˆKL¦˜uú8á°¡¿ cjüðÈûpQ‘º“r:tàÜû'À! :ç$/ábÍBk’–Lûþ›g/žÐ¥ô¡zg^–c®ŠK‡s}¹xûáí/—ãêý1m„”‡Çøû¤ŽÞ2ïÕ(Y› ]¿*ùòêý‡ó1”s{£Q‹[„eZ¸Öç}«ÙË1Í"î[©±Búþ†õì|”†gÊ÷ÕeÔo3ÔòžÈÇiï9W®‡¡{µ ÚÉô ªrt~½u+2t/ø©@°€æHû˜@üŠGJÆ´•e›Wãê2È ºn"œyÞäÍ—í‰q²WߧËç?ŸpJZû€”æŒs;tÊ)ÑC)ÕCZlVó:¢ÊW«8i¢ÙDÀ—n¨æì¡I«60æÝB7sÑD/Z#›eC7XäÄÝí:/©~‰o³Íz»)‹²AÉÔ¦\µ[õfMlLUŽ•»År¶ˆÓ¼*â¤Û[–MQu¿h6q5JŠÉ®F—` 5jPTë”D:¶CQŽXÒe¾ èø1RJÔµÍg¿å·øX¨ä2` $çàà!;ÚXïHøp4¨€Î\·Ï‹_9—%•~ZÞ”Z¬›–ãϨŽçö$ïÁBdeÆ[Àæu½©jFý]§6ì•Ñ(ÎPP\_>ÕóÙ_ŸOŲ‡G#må™wÙcb™`)Yÿ`£ÅqùêEì4RG`M‡p^TKJX³’âÃbóQOe»õU‡ëMzGüKKòºh”>ÊŽËr¶ÚÍ}CžÇ(… ¸­òu·š7q6ƒ‰êÑš*™‘}V>US% a–ånÜ©è0’¼µncà&àšµKpýûX„¾Ì@¡+Ò}®ŸmÊzYSDNq$ŒËò¶åÕÉQﮫͮY–Å(|¶ýô(ñÉ`Ñfî“ô®G¬ò-´¿E½j:âá¬j%#Ç#Ä™¦.šÞ–#ꑸθ‹œ£«å¸pù¨"…8¢d˜çê«Eå\ûD†ÏÄ‘Kœæ­6++ÚdDy›"¯ÙU£âè×­ü¶ÒømŠ†\?¦_S> stream xÚí\ësGÿî¿‚ûtPgÖó~¤*dYŽ•H–"PîÇ°„l*t€œ8U÷¿ß¯{Ø…Eƒ_+ßÙŽT¥™YØíéíîé×ô Z/[¢õÝ=±Ñ?ìß{ðب–+¢×¡Õ¿hIe MËùPÄ([ýóÖ³ö~ÇÊöÓŽUí]PsJ—h´×yÞÿþÁc×Àh@ñsðóït•RígèllÏ;]©Lûœ:Û>KW¦ïž£Óª=îtch_£Ëñç4Õ½½þ½ß“.Z²¥¤.T @8Ÿï={.Zçøòû–(4¾úo·ÞLatÙêÝû1½{ i%°öõwŸñÄSFbÊãpôº]ÐKÙö+ê^‘‰P£e7 Àñ­®ÇG Z¿cuûçŽ5ícåH§T¸%é@3)T»×ÑÔF³KÍ/éSP+˜öaÇ °ÃÄ4:¦Qï&¡dO$qVb‚&t’ÑÞ1 ¡–dêÑÔ}šú¤Bg7G§ Ô:Mz@ 4?Rsº¼ô8ŒvÓe‚$Ö!iUD]ƒ´Ûé:!ÚûOOûix¼s²s¸×ß;a‚ànÞÝÝøËÞ¨ ›M_\Çé±óáÅh2ZŒ¦“ít»o.ë7÷¦—¯‡³üWaEïçÃoEº<ÌߌÇÃÅltv?}B_Êåð͸X¾ìt„^é Ò’®=¡Òð»ád8\V'ȘSn•þ›«az`z‘ú«`\/Góñ iлÄëÕt¾H£ß§³ßF“—÷+–¤÷’k·L¦õ{Kd6¤GûB¯c·RLý¤‰0ú®ä“.´Òåê‚èÑrô´ˆºXÅ@ч%¤b{‡š,4éùó Ûßwº¶}DÛséEá”ÎQow:Y̦—+ÂäÃÙüC%çSP#–´Ø‡r£ù¥ ûÔàÚ:f-FÆ·Mê–W[ØDKÓʚ⛥†©PçÚ—”d,œ0%R»£€Ž¡W2šÑv ™:›àmCGAߘTFTÄzšîpëü‡!Š«;þݬIKÔlD4Y¼¨ˆé“ 5YidK*À¾ŒˆÚ¾=¡ŽM]]§nA·°5¤˜€Š>¤«YêF©û#'›ÁN†œ¨íÌçÃ1ôÚy’ÎÑäêz¹Çè…?Òø›¥&š—*j4_ ΆoQiÝ÷üû$²m|BeG¿’–:ïIÀ½ÉC ¯Ì:-S¸(Ž‰nºIêÎkΪCtÌ/ùNt‹Ô S÷²vEò¡ÞɯDûPAý¢Ó…ôüŽ–)%ù#ÁEò§"ËU4ì:v4aˆ1ù.¸©È­ï°òbÃU" o+¢/×)HÒ+ñíâæu~ðΤ&Çc‹`×™âñ¤ëÈmÄwK]_†!ê Bd@Bºb…&ˆ)CbW`6GÐ{;óÄ[˜ó|yç¼C%i>NIº"h_âÿ ·~ ëdyÃÉÉ°óøŠÛKþdÈã?òܲ‚r?3 ðÈéÛOŽ(š½Ž ´Òh•_Qó47U„zUuÁQp¾I]Ü‘Å6CUhÓÚÆ<–f$©Â¨O£=äƒTFSÀCßÉqNZU»¡ŸÀªr.Gs9,•r´e©ý.Ú†í´mç¦íʪ}$qõMâ-Èå–},¢q5O‹ôò…êÖLºP¿éû›@®Ö`¾á¨žæ°c/®¥‰[·kC8fo²~CûÿY.s“dQ*vÍBÒ’q°…6±eæšÅÁ²pd Âê„Æeè“Œ÷ ˜Ÿ[±œKå+¾ËT»Átâ¸Ü§Ñ¾«F[-§ù Ë ÷†äýRä¿ä³#`df¢¡L@¬BåÅJ&0y²+Y™°…¬yÄï6Üæ= ·ùä†;¬d'§þ¥)l45—÷#õãÊ üOŒë§0QŽ9S-DÂ|C|¡ ”™ñ±ˆº™ÇP(g´`š9åõ°þµ7dBd(ÔÜM]7ˆÐÝ jZÃDÌ{5Ë¢°åêÚÃèAKþHqü‚]ÈÛssäçåBFx9;Ù$Œ¾eœæ qá!cMrP>® |ªiêÎr.”’Ð?Jå2§“Á;rï— ¸Õd8Û̾bµJ¿ÊßhrÀ4mfh’Kbaøð8ù_®Ž‚h@dÊ'@NýI2²äì+—Þó€Þ@ø‰š´•Óz © ñË›¿Z¥8{žQzxkãZF™|j¤ôD,†FAš¥ÒÛ#¾sŠØT º®ò u]̪¼Ããý¤Èv§ãñõdt6XL—ªm0)µà9‚ÅÑÅ:ï£SžŸJ¹)A­’æní·‡h=ZÄÔ¼Úm.· ÷iôhËN†2ÙŒ£Ùùp6š¼Ü Íülp¹Úâ-#ï—£×ÃI¾x“úëùú×ôj1"#Õž .ß¾ÿÔý€?ø6j›[ÐéaÇ^ uiW¶Ëªœä+ãºÃ/¶ w…V®Ùj§;ƒ‚4WÛU¡JÕ Ðýp/žPÓ[mÎ+RÕå>¢ ¾|RÕÂÜLá#l’5~ÇëÏË‹ka\˜ØÕ¹‚&-ñ$üIJŸßÌÂ@ïk›@)€Z‡tÙбâ£L=£ÑUU5R] |,œ¿‹m y2ë°ÐÄwf¼Êr^E° ÄÖ*V¸fiÁÈy…eÅyM¬;B‰ûÄ~´‚ó„RÂÚ±px–T—U«’¨6GX[J>«:ÂǪ±·•_«®–šê4¤i?æ1é'>¼´:­×|n~ 5ì´XCE< üÂÌÖ«¬ëUš¾JÕ €$ƒBÇÚ'$íã¹lWƒê»àMªÂpeÆEºš¦«Yº§«AºZ¤nYù3­±$*øNÇsõiêæé ¨–:°ã"ušR;ÆQÛö›Tç³üˆòŒüØÂö+cw²ÿôñQÅé%Õ:oJ'úHüŠñ'I—¤<*FitD#⚊[óo€ðò¿žÈLn‡¢wöêzöé6¯£ñ«S+T0¹Ï-ó)#±qÜ+øÿˆ…TœitÞ+Dܯ”ƒƒ°†Ä.Oÿ„ǧܞ¤š:Ê:…昚“N é ”/î¦Í(Mu5†N¬i:ybHû AH9’tàäavã!5@Æ1PMš¨8” ¢¥×¸ÉSÆÚ“fõ”±FóCnýXYxÄâMbVä½tÚ þ'Oit’;§9öSÊp¥[£#x‘ ¹¸äÈár=$_e—Ò¥Éä’¡ÕD7M£f ls*£Ùu¼ •±…wªŽâSš÷€08Ja=%.ZÂQ|„æIGià¨LGò\|¸©_Ø:Ž4/7ò‰ãPïÜÓ¦u!XÏìzôÐSMÈOøßéÄËi»ßyÃt£2MË¥<ÌòªÒetΔ¶ èøiØRwâWCßåU>ÛÝ!®8·d•,e­¥SêÕ Ü0ä0j>fkWWU‰CYËp5›¾—qe9Ãáéáqïí!¬¼Ëž|äV4ÕhR š|Måc¼C ÉaÕ䦾÷ÑæëOÃÙœ¶ˆÓ‰ãëñ‹aÖ_s7•KAF‰ qwx|²6Nßöù“½å·Ykj$¾9µZWútn/ŒËhDp«õ÷-RÉq^Í¥«Ä6çT«¦j MšM“DèÈx”h™ñ$+,éáÓ{ÝÌÐp5@A\½©üÒ´:$?\Ã/ÇR€ÐõãÄ%KŸÆ§}.F—ËOÓeÆêz|µÌXUKyuŽ4¹y(h<˜ýFNêpYôz1áë/ZV6$E%I±éʦ«R`"\tM{^š¶·4\Ò*c(*˜@l!,¤n(&´µ1q$5U®F%4Ž¨yHÍAÂE«*u³!+‚Þ\éÚõ¢;½èžMgÃÿ|]ëÞ%þéõu/mR£kE[GT2E›\é—96—¼-Œ´-‰J3^zx3€dŠ+V–µb\5ö˜š}ºüWþ„`ÿU-¬XcˆÄEѪRy†Pœƒ9|¡TC~¤0‡@ eÊ_¢Á܇®åSTŠfŸ.óί’¼-±ÆþÅ–§ô;-à¸Pý¶ íœ[“ÿY ÈzâÖÛ†N,"„lIgÄ6#–¤Ð>0(aÍ;~ÝæÆ/*1´XD§ÜR’ó[H²òˆV—9èÇ£—×3Š´mE2a<¹#NEgÓñÕt2œ,æ˛Ⱥñ`ñª|n¾˜]Ÿ-N©WÓ*§xë§$tïÑî/Ï+_µN;C/Šy-´}GYv ±N»Ú´FƒºX¶ qò’vý“ÓÝJÖo.@ãÅóá¯B¨ ù×üv£Iæµè|Vh‹ üŽv½=›ŸŸýù| +Ÿùy(éBûÐ ÉÅmðrÒ! Ž )¡ÓỖâUîíà@™JÒ‹¬¬´¢+ŒÆÛÀŽåÑ%k÷âeþ z;pÄ endstream endobj 1178 0 obj << /Length 4072 /Filter /FlateDecode >> stream xÚ½ZK“Û¸¾Ï¯Ð%Uš*‹‹I0)¼Ž½5[ñ#žÙ¤6Þ=p$j†e‰œ%©x•_Ÿntƒ/Qg“A~|Ý 1»›‰Ù‚Ÿßß\|÷Ö¨™46‘šÝ¬gR… õ,²a µœÝ¬fŸçáåB !æ¯.U8xØäË´ÉËâr¡B1ÿX]J;/ïªtKWE“Uët™]þzóãwou2³AE§³…‚>7ñ̇jÞÜç5¶ä¼Î–8õ‹Ë…íükF½«¬^VùmæGsc›æ X–Û‡²ÈŠ¦¦/åz4ôßHzZåéí†çÜî¶5’xñææâ· ´‰™œ ’Y…Häl¹½øü«˜­àã3èÄξº¡Û™ `œ˜mf×'^öjtØg2Míø!­úÂÖÒ&möÌ,#z,´„%D4îIÈ<û|ý××ÿúõÝOï>^R/­ßaÍÐÀñ©§Q?X\Ú8ˆúP‰Ö´öõͧŸ^O«Jܪ‚Fý"BQgnG j"â‚pV¡Ìù—O?\Ì>/´Qók:ðKxÑsÃÿxÒTdAG!eÚШí®v-5G‰Àž:ó{êp玻:«.˜»I¢yYQw7YZñÈ*kvU‘­x@95QÎ$q¶HT ãpx278Vi‡œn3ЂšÞ—eÑTåf“wÔÑø‘)l%“Ä“• úQ:”VÝ@ul­w…ãXºÉ›<«ûã{?¤Ë/é_¥ò½Uy)aµ|…ût?ò¬yñ°kÜÖÄpSnÙÐòÌÐH«*Ý×âj¢ ¶Ò ÁÕë÷7›%•«‰™$Ø 0G<æØD2Û1ÑvÅÄféòžZ=Q‘tö{;{‚o~‹«¬IóÍh»`Sª=5“ÃdÞ\Êùý”ÂÊ$ "ùÿcÁBƒrZhN¬Ê6iƒç+“ØɱLx?ØÁ A†%šD»a›yÅíMŽú…¡UÆž;R¬àOÅãú¿¶ú/ÑX¿™Œk°°h¾äõ'no¶ËÉ‹uYmÓnʾ®áe1%Åå®Aùî±$ÜÐÖ*š"õŒ€¼Š˜•§â6ÙüÕé-Å=Ë„ohâzäÛNÕ±w›ßÝOêñ²¬ª¬'‰Š'Ž *öÞìœ%þM¹L7ý!‰×& öc™Õ5ZQü€†þˆÕ2tdga’ZÛg¸Q €A„4“„™¼ýÓ§«÷o?!)íÊuêÀ‰8 ÿjŒÔ ÃCjôVDqÈòq¸®ÛŒ<‡²6PB OçnSÞ:¶~ˆ8vÐî°q©X¾!$ƒÝí¸ ÏÐSMï§ÎIG–É,ªtœ<çœtA3É8Ó£­œ@_øÕç“c4Ì…‡ä8jð¤Ø“+8É(Ç[´îï„ASëôË¥óŒº;€Þå T³§Nd5m^¾:ûcŠ’z ¬w5,t£}Å®s8Ow„&WCªly:ÚI:°‹Cˆ>Mµ[‚Í`‰s"Ëûc‰-‹Ížâ–Ÿðs^Q³Ÿ^ 0F¡æºä!òç÷tû°É^PÏWFÀISî N!Ræ Ï(Më?Ý~aJϤ²œ˜pv˜„þ¯c’%,˜‘YE‰ä3€±³%ÆM„º“«#{2602é€ ÑA—„ãùq ¾Š T`° qÇ]?dEVyð¿"ÚVÇSö%lûKûÓUø@âR€€¯6îë¼æ׷Ζ,›²»vŽ™ßo.A¼²j›=³„¢>q`ö˜i¿á?|?A·ŒÀzöÙêÁ•VÍ8RŽ&JŽ.ë~’CŠRz—Ud—5ài´¤ÐzrÏ&‡ü5‡0€¿fäïZ.LOÎÐbGßÐÒ¤ !ü[J%–Ó²«b€±¶UŒ6¬oå¢'Dnê+Þ ‡5õ6÷¬ö$Ã&£è‘ã4Åš°‡hز­Q8$Õ¶5y*¥.%À¦$ç劲ñ. `N¶:±*ð'‰Õ7­ú‘­*½ €zÍ5=Qžˆ–*û󢈣ˆ¦Y€ô†ŠUÿÅè·i`}Ó²­7 ÃÄ &=ó¢nÒb™á™tìuBˆ y°³$Žç¯¨“d ÇÍ›{êkÕ#ˆèG¢[Ëúr‚…`Œè4ÈmËÍH:ƒ«Üzb² ! ž¾z©çí€ÎíÙµ* …'%ì õÉZ¯Ðrá¶MXélÔâ‹Ó;k»¯5¸$jy¶cb8_§8 C爭U¶FÉNw›†–h墸šºœ[s õhë9Y÷i=!œbèUO¦fPz¬g€>Ç)‘aŒ3X[NÍhDÂR3;„óFšyZÓóê5ð¼ÃìúzŸûQÛtO ‡°åAêN}©“ÅÚõî¶Î~Û9 ïxÒ5gN4Øò‘LLšF`LòtËhãùû²É¼È¸DÅx©Ê¸s Û=<^åE¬ÅP®Ÿ´Àƒ<}uBµç¿oyå¡,i=‰½.<èØ9²Õ-;dJç\8®@É<¦h€ÐZ ûÉx›vh0·›$æ”HÀ$€…­ÞÜguÖÚÉ‘½ fR*4“èµ ˜ÉÄ žÆ¿Çcç‘€¬Û–¤×Þ½;el1)Ô­'éÔ€•ò\ž3(™×?Ÿ¤rˆ~^t¡Ñ)ráðbõ¿!÷ã«Oç“Ëa“6Q'tÈ XIë”öZ‡­|í{ø)¶H…(ŠÑä”NæÛr•¯÷ÔÊvš²n×púŒÍA@D‹ԺϾ«ýʤÂî;CÙ¬£­Ÿ1±ÞU{ìÑîùªfeQô$MS–3ý.ôéCûͧ ¾< ¨Êªäi– 3Ç`un„ñí®B÷¹…1¬÷°nœÕÖ¡aÑz|‘0‰ØwÌX%P§)L´PÈË’Ñ`ý"ÝðÚmX{j@Äඃ™?_ýuÊ×ÄŽ´ a7 éšfçE“y•_¨ËùÑÉDwq D]_}x?•A J—§Õê9%G­mZìf’Ê;•ŸÞ}ÿæ¤{Ò¦WzÖé`úD=žãq¡‰;ªË¬‘„£‚DFÏJ4S,㓺 Ù "w5ÿ'A_ØV¹kåz±,«¶p¦ƒhìÏ)ˆ¨ÛÚÃj˜›>ÿL!ÃxP ÀI”òÉécvÜå÷[þ¾”œD¸ëþ^¨âÈ^6¨jã3“©µÊ6™³'§¼ÄÂF¢‡Þç$Åí£Vz9—çJÍÒ•1.£Bó,Âé0}ÏyäÃ}Z“‘Ë›²à¢G­‹í祖÷%a?µ¿Œkj¢g]•Û‰r¾ÊÓ»Ò¡{°«ˆÆ)=jà^[~óe•ƒ“Íù~p “gò µÐX™U²¨§®±ÊG`Ì(ëWÔ¾òæ~L 9èÅáÿþ×mÚTùïì˜ÁÅ‘0°¦•¾WÓéYÌ9·idw'uJwSik¼ƒÐÝݨ\,c¨Â\Ó g0ÁEûdÈ“U"¿ÅÓØqÅÙ ÁOÉB×aèèz'F•—§ÃÒµû·¤Ï¼l2“\ûl4‡sõÑþêš#™æ»\åf?}s¢ Åê‰ãs¾j¤^ßVI[ýt¢·ôþNû¹ìÖ­ôiVK°×'<щ<ÎKÕåû¡}nß&ÃHäÇ¡åC“cî”_ I|p!z}P1çlO[¼ö͆£ çÎdÉCžnÐlWØèÀ¢Çtˆ›|Aþ¼¨/3õ£ ØHL^kôìèØ.ÕèB!'áé”êö¶Çf«*ÝùDé’±l—„9C¼Ì”tùœ”oÝ2Ùw®¬íV²!j(zWò ÙÀG„–™m åLàËmJnšnÃ0Š8}Åk¯Yr šÈÂxD¬YÝøiÎ"aðà¸a®0Уã&úÛôî¹€‚!u ½ÑYÒÛ¯÷È>a ѵÕ(Ó¨gv´2}–éËð³sjýñ`ÄîòÂ?îââ¸g©&=œpгª®àâ¯KZÊEOx}¦á—ýˆ*Ž¡ kµ«ÈO+Óeâð>ŠFµqy8íCgxm©¾àµI4ãcà†v²¤äM{£f× ú(ÍÃÅ*wåÀ«üåÙ^PÓq\‘ƒ1gÄq6„qO3ÐìôúI6@Ò.ü¥ ¾¯­&€ÅZo\ܘøb5æ£sC3°¹òtQ\ î©PlÖ¿ ·D$ÅcœrˆAÑÌøµ¯SŸÌ$A&G‰$õ P^ûÌØ8@€"m(?ºtÃø—¾ ‡wDu“ è?ªõ*UÑ#ÀVu'6Rí30ýÅXµC{®vÎ5´#\{˜ü;G& W€»Y£ ÆL˜”o P•BpÖ“½âRyBǵ¥£ç™Dî’­Slj·Ñ¢ƒZaÌ×Ô{fÏ]=7R" ;”4l uu8ß(ÄÇ–·ëØnü\È»ù ^øó ÞÉÝpÇ*_ãŠî‚¡›Àá`Ζ€‰Ø`˜b¿ÝŸ<þgæ¦M ‹g¾>÷æƒÂøO¬ºhôàÒ–¼½w[•˜º.šàP »‹(tÆvîÈr‰U îÍÍÅ˾¤Å endstream endobj 1058 0 obj << /Type /ObjStm /N 100 /First 968 /Length 1399 /Filter /FlateDecode >> stream xÚ¥˜Mo7 †ïû+tl/Q”H0än´hûÖÈÁq¶ÛÄ[86þû¾Ôz’85Ó^v(íCR#Rœá ³TÒ-µ’¨i=Y¡D\p­‰ÔÇœjõqKU|Ü“%q÷±B»l†Ij­'*B©Cè–”Èg8ý_ ÞÄ(ruA’épAñS›K>Ôâ’%"ê›ýÄçkqc ýÚ'‡Ÿjs?<Ì%ØkÓ—›ïÕÍ+þè®V4„ÜÑ€=‘Ão˜ÜÞ`¿u×ÅÖÐ(S–G›øc˜¯tÀ¨µ©?lÌ9KµT_HêsF©|X…$snnëä°±µÏ¹É朤ÊmÎ)$sø£6†s*°Ü|¹„`Õ^‡K°Ü÷A0©¾a3d25`YijÀ²ö©Ë¤©O øðHbÛáÚk „Õü ¸°û †ä›HÔujxbèÔ@jTš Éï—0dÏHÉwqLÜ|w©$ß]ªðÑÌ}Tøè¾»„´à>¦|O øð¡ž9„`©‚ð ×@*ó×`ø°â0ÀÖݳ'¯k°‚65:$›Hi¤“KHròøú°UžI]‹l\]£$O`ÂÖµFî£ÁGó%´õ25à£÷©ݦ|ˆÇy ɦ|(Ï,†õ˜{J!ø®oƲ98Ø,ÒÉ@®”ô4-Ï~ý-™e†mÅÎ^\¿~ý|sïÞ9ê”^w“ß—2­"orElC0)®H“‡kϵû¹«¸J––‘¸A¸ –…ÛÀÚÃ0nPï‚©eñ²X9 Rû|¸»¸Ji9ô¤Â›j‡HšŽïÈ¡ƒ‡ž]ØÒ›Òöì-Ï~yñÇöloïñJCoL<~S1à÷à“ËÝÙÑö*¤åɣôoß]¥÷k:þû¯-þ8}µÝ,±¾íÅÕ[¯µÓØfyº}»»¾<Û¾Ý×ß9÷óöåùéƒÝ»tâ‚5©Õçptz íä‡or÷/.v0v²Før>ñ:ÍrtýâjŽ:¿øs³<Ø]¾Ü^NÛåùòãòxyxBsàËÁŸ R "8ÈOórâ1G‚4ÃØÜý¹-Giùaw¼KˆÒw¿Ÿ¿º¾Üæú½ïɇàÍçXä4Ýל@¨³Wç =z&ÓªO¯(-–Éâ4ÊAÂq ×…Ys|?ªG't¢n›[Çë“CôŸÎŸ mßt6>¾W””X~ ®UWFË]ðd“°i8Mqšr‰/[8—¦{Ïþ¤Î …iƹiqš2Þ£45ʲœ£pÑ\%w$^”¢0eŽ®¹ÎÜ£°vé(,šÃAéÝrka˜2Þº¢tãÜ,LsÏ=¾ÕU3–¥Érqš²P˜.xYiQºYÏ¢azhÖ¦Õ²†³¤¡æ¨„iÔµ0š3j˜FÍ=L£æŒ§)…iÔ' Ò¨:Þ˜é2r)¦K.¥Ùjö¯A=´Jöþ1HËÈÔãtÉ4Ât¯_쨾B7¼ç¶0Í’½Q Ò­O‰Ó¸r˜¦šYÂti™-JW“ÜÂϾ:Fn=N—ì“‚4zØNaMloч%zc¼Ö…i´±RâtÉ~lW®Y$LWoÃ4IÖ¦Q}´Çé’uDiBõ}‡ TŸ~ã TŸ¡aÕÇ?ÂFit¼¦Q}LÂ4ªY˜F+çvï ñĶùñ}3}õóÈ­þívg÷¡û¤³#ÿmãµv¤ã³ÖŽÖvïÛ?{PŸ_L\ U¨«À«ÐV¡¯‚¬‚®ÂX»dµ,«eY-ËjYV˲Z–Õ²¬–eµ,«e]-ëjYWË7•æ&þ{“Hù endstream endobj 1213 0 obj << /Length 3978 /Filter /FlateDecode >> stream xÚµkoÛFò»…ÐÃ2o÷Å%Ù"’ 饸<.q‹¹~ %ÚæU"U’jêþú›Ù™åË´#)wlî{ggç½#¹¸YÈÅg’¿Ï/Ͼ}eÒE"Rçìâòz¡l,T¬.‰„2jq¹^|Z>+Ï/ŒM—Õ®-*.çç*ZþY4mƒõdy]ÕÔÑÞæTØ7yhªè[”»}KÅf•mŠò†æþk嫶ªÞˆ'nòöü×Ë¿}eåF­•‘ƒxèÞüôæýG6:Š‘Bê8ŒZU[ØœAËömµÍÚ€ØÜ1@ûÕ-.²¸Ð,Ÿ˜Å…’"Rš>QGrùoÉ&Ïq  S Ñ¢F¼†Ê‡ÎŸüàû«&{äa=FhžJ7Á³rý…'¸P€ gºS¾~ñöòŸZÿÔh‡ v¬Ò$aží!øϾi©t•ÃæTö—Š…r¿ÍkÄU¯Ïh)þÊð|‚p¨œ.Ž  E”2¢9ˆt^µš¹]cêK—«S¡l7êsÑÞ‰·D¨Ä†ù?¾{þ®”^HÃ৚ ß0Eß]¯òu¾æÖ;úfÓcŸ­ŽEë#ÀíŽö”ï5^w“M¶åRQ6mV®r1YÔêÁ¢Úi¡^©Z[ZÝ<G*¬‹&ü‡Ü;†"Ž—MµÙÝ\˜$]¾n©dÇtd]Üܶ·È!¾£)Ö¹gÂ@é€U*…íIäù %ÂFݵîê yü‚.vô؃àX¢aWE^Ï øM^æuÖækæˆÄ8ñXªø\¸§îóõã9£˜Åw|"}³4pžC=\pM$©9£Os×´ù–ÊÕ5Ìß{ÀÂwdGd ‚¯Çø³_xÌ„1cÛÉ¥§3«¤"•æ±kMEwôªdn‰¤_â/!‘HãØeHé†ñM]ά‰P|15{ Ò_u `þî<È(V-/où*vYÛæuIDf¤)ˆÛ‘­¦t˜Ž–ÙfïY+éÊÒ@ÃP•XRgs[í7<ñŠûwYÓxæ€þ}¹^¼ÉyHS€-/7™ÐIJ;+êëöœ£xÜê6k¼r…sÓi’NS w§òÓ‰8ŠNŸžéÆ-?æˆAb„šT`ºÜUMS\›¢-û¡Û…‘±Y|<û׌ýkÀþM%­iͪ!«ÿþá s@ÎCÃ}Ûp6¡„dp×ãY‚l0<ßV´¾•½¹#QŒµ`Ža9Ãb¶Â†L V›Ó4„¡]¶qðÐÆ:*¨‰ ¼d^³iQ44pHxšƒ/®²’ðmš* ‰¾û¦Ó»,P§Ç8öÄomïh1Bk¹÷Ò šš]¶âÆ«¬A€°ÕËMh™w³ßd5µzŽXy}'‰)ä+í=c^G_´æÁ”Q#kþ ¢QM­̬eµ6ýYw,«4èòºlð†4Øãü­ó¶sg@çož0¿Óû^‹¶Ç”@øìÕHC• ;(ð™}‰--4¥^y¹BÝñÌ«6+ÊüX'Ì‚©Ûõúí«w?øÓ|Ñ ‹€ÿ{Ù<:ú¸Æû¸Îk/ü¼qXW[¾0&»£K‘¢Ó—c§Ë ¥“¨€Ò¼Ó gÝNWš|Ó•‚GîN9=K_dÈœ¾½Óe¬! ­ÙôØ'@k¬0Òf5Ц^ê×T†ùO-‹s¨RÅ„p‰%¬ @hðÍG·{ “¦DªöÑ Í´ÇøhW@ý^îÚ Å,ZgÞ ‡ŠAáwØ!:íÊmïoŽ!ªHö†3°ô‰phPIÀÍÞ9ŽƒÀ4¨F4ˆ­wŒ7´ô¬` + xÄÊœÎ{`À‚¡'2ã>"¦Î˜éþé¬qie‡)Ðîn‘ËdmˆN d0%ë$ê)[¦d@Fšž2Âý ïaÜ'=I´£€æ|D% ‚ðÞ\2$ZßzG­UÙcK$ZP1‡ÐlÏû'ÅèljO–xŒ*8Ư•‘zz(lFʺSh³g5 Íˆ£)4lNZ!͉‹$n«Ÿ0x%‡5‘°Ðè~ݎàêÑ0¨º',Œ2Ƈ…íW†QíÑ=ÑiÀpQÏÿCzB#ËiG+Ø7‚³"Žc‚¬ôš¥\þ £\æuÓ½,”ûíU^Nó[oË]¨XHŶâÏ/?||ýîí}ÿZÅJ8 t«Òã|ëqD6ƒJá*‰H$ïùö§7Ï_~˜Á¥ ˆ–¾lÀÁ*oØ„ŠÜÒ;ˆQÄþ74©Ý§(LàÌ!EIgÂû«ˆCY¸Ç|ÏØÃxöeR$“mÓHÈÞ•;lÛìº kf´/Û‘Ä>P›ž‰E[d›>’†ÜHsx³:2Œl„îÝ­£Ð…"oÞ›Æ"ñ ä`=G#^!NÑ:Ö ¦^Ð&(ï çð6˜÷±sG¡’Þ{YƒÆkÚ ützÔ‚&ŠÐo¨R”0bëñÆî³Ö>ЂÛlUWTìnrÌ!V:PˆjaRåOzz $ˆ¾áJ^ 9“@mèKa<9³eˆyèĈÔÞs €€ÀŠ%š†BQ®6û5Wpþ&of9l«.~ý©Y¯þúõ0œŽ€èA¨˜DŠÄÅGŠŠ‘ÝÅ ñh%çXò­Äí õÖ÷p,‹–ŽµªJtèªeô!9‚e0ÇõvÆ ÌñÀ”hY9·¼AÅáÞy²‰pQ<_{™óúóÕ«»ïfPè„þ¶Î¯Án8¿p ó Ct-ãðQ!ùª°BÎÁ•âð¾Ñ‘!‚ð×DßÌExáÒÒdâa8ôà°ÛìŽO¸Ž}¦Àõ~Cm”GXü|[q¡hn©DƆPSà’‰¼ñ !¹q2¹Mèéä7”³¦©V…ªóƒ½¨íg§ËÛ<[Óà„¥@±#¬!?«%±”¯w£ žœív —¶…\·Më¾{¤_ÒÍøÔŠÀG®Ó¯<Ê•ch¡8«g†ü^¤ÃÛ pÙ Víþ^±pÅ WÙzsGC½f:ÇPmñ—· } [‘‚ì¨\ž®6¼Ì»)· ûî\E-dœŽÑ好7¯VU ö(«#:Úeîšô%Þu§Æ&Ö™¼o—¶Ë^€Ø©ÏU²¬6ãmv(œM¾)šíX%ß3ݬûGÁïÞ¼yB\÷þÙ‡Xf¢˜€`ü‘eÇF î5g©h¡¢‘9V”­'ÿ›¼&›L¥ {XB"À¯·ÎTšzG<ª±@¯#XÂÛÀ¯·v°°««Ul‰ÀÏåÇÑü©µã'’µƒÅã­pwE¬Ôn -Uî±à”z'Å»=¢86¾v"N&äËNh™²â‚g*øöÏ®Pñ,ßë} h©yD†rhÓ £%ä¨As¿fXÊ_ è™ßÑ»~÷P\ð&oÞ¿æ…«ív_¢«x«6âغéì]»ÁÝ3ÌD˜‘1ëå.9»ñ)Æ?/{EŒ= ´ñõsÆ°†âùAN$}°FК”]bÈ€‚:á Ù oJû0ó^0 jÃ/»¥¦O9á$²"aáUµÃÿ5z‘›A¢§ØE°€’ybÏý†kå;ÒY§7’ô~ºM’ƒ"å©+Ü°mhí.u«„u@NÄþëù+„`GÊaŽ%+6B¸ˆCÎëü÷}çô‘_0A}ÆÓ&&õ «,b ïÏS,DKÕùw㰌֧¾ ˜NÒØï¦ñ›(rœ 0çÇHE¾4|ýuø†òÜJNaà|Åu×ã¿Ì*ª3ÄiͦÍw¼ªåÑÈ™5löw„…Aj¤_ØãχBV´¹ ò_€¼_X°›:‰ ¥ÛÊ D²Ã\¸›* ඦAµËkŒ^QWs·½ªÀͤ¥¸dámZ:z.žyÜQ†Kì‰ »&2g¼­  \!–)w®lµ?t« ¯:oö›6&2Ü#¼NÂŶ'ÂÙ ­A}‰T¼/W… í"P4…Ì°Xž›4 Tá-þ®aٱ̈́Mz¢ñZ‹ˆfÖ‹œËjâf˜OÛ1ÇJ‡ŒÁŸïz4MÙ-ëRôë¼çøÀ¹j6'„•½íclݪ‘¨±|4hî¹*¶œüm`­—-ÿ2ÀrŽ•¤Á°¡¿ßï±´Õu€«ˆ¡qÉW«z 0D€ôeõÀ–sÄ:4ü²÷ºÛ!•ô¿”ÂvÜ @Þ”žEíëkâH¶êí€kã(p-÷4ôÅ 2•,ox{ øFÛª¾ÅŒ7ª7{¤»ÿä9ÊÎÖC—œ×â‡0vy¿4}+¸Ûº‹Ý$1]o26¬çñ›`h•í½Äá~“˜ö°°É³5MðªZºÃB¹Ø^e|{B¹À”ro·˜vsà€" ÿÁJ<—fæ–™º ¡¼©²u¸ã¬|D7> ¢¼2ïƒ1ÊI§Õ3è~üêq²ãË˳ÿ!P@„ endstream endobj 1233 0 obj << /Length 3693 /Filter /FlateDecode >> stream xÚµZY“Û6~÷¯Ð£¦Êƒàä‘T¶ÊñƉ½öxÖžÝÔæxàH”ʼnTHÊÎì¯ßntƒ—8¶Çž}P F£¯‹w ¹øé‘äÿ®}óÌê…R"uN/®6 ¥ÐÎ,¢Ä eÔâj½øm MgçJJ¹|^ŽíÙ¹vrù*kë⯳?®^ø9R‘F:Â)äâ\%BʤûX(þœ¿ñß··‡œJ¿K'y¹H`žÈâù¾[!°f8¸;(ÂçË–Ñ ºi·Ù¯˜È–“cÙŠu§-ßÏ©Š±Àß4ŸñïZGŠ8g"Eb‚…¢Á g≻Ï×ÔŒ›ÑçXXÙ‘úê_¯.ßÎP``³¦Óúªôk­uQ¾£r» +{扳óÈšåóvHèKÕ2y»6¯s¦y–4i‘êøS´éH$iÇ?A>oy=²»cN«^iŒŒ…ñÆgÀÑUµßK¯ÏkR”Ѻqº+ É*(Õ¬8¸kVª \5èkQ£.PÃ˪i 4U¾³#ƒhR5ˆ¦©óoG¢úf ê›yÐDµ¤±ßNeÌYi…êyôd†‹Àm; W0IDz¹Ýïs0\«±9X€EÖ¢ÙÑ›}üL= ) ŒI:$ÅD°´9îI^"&Š½‘ÀzG%UU*ì}†­óߥԠìᣊ'Ûf-Mwào4lX·æámvƒ¦4/©º©«}ø>,Pdï*¶Ë´±].Úm…¾Ú€j”° ÆûêhqÒ*k{ ƒ´Nl:È—SõËz¥vKŸ²BÂøꀃ•eUžÏ0×bÝh½;õ¨a@¾wa« ¯Ä7,­Y-¼räžãdcغÊØe»fâ‚Ú:ª Ïë6ë*½ª¡ynò<¬»Ïê›0ۮ…? œJ/KáHzõÿQ‘Þåe^ãIc¥—V/(:IœŒ•úuoW¦f"«çØ,ŽÝÁ ¶vQyˆ¢m84˜’l4 L$¶{¼Íd… ¡‘Ý­©ñšk€!$»ØìݦŸ…zÇû¢³,6aUÏBÿŽ…Æ“Æ“ãé>ÆbÚ·ˆô ÎÈg·*¦Ô[Føó YÖTòÂv8pB¶ºÉÞål¦Ÿ¡N„Iº1à;Xþ¢Rº!ÕR U`å÷jLÌêXׄäèK>Ë™M…“ÅI4SøËY"—ùÊ·ÍPÕ‚b{á’Ô<ñ8?çõA·õ<(W³]Nø]àfÆwëD cÜ}}wˆ%†Ø±„A#Œù†õܦ CM§…•#Àj¿›’óGÑY„˜/Eb;ªÙæåýÄi¨ÊŸT@˜d;ܧˆâ¢á,ÖTE‰Å-x ÃzÁÚƒä¹N¸¤íŒcu·ÄË¿¿äAnáDÇ>XÓ°e(‘H¸«Y¥BEÆ[©8â(r.¶H£{*Wò5ÔÇ ÚŸn«]ÞÜ DÞRË“…PŠìUšéÔ‡á˜ÎûÚØ¡s˜Tmè?—G¬›èà0%IF†Þ‚ëÂ'ª$Ö¯ùŸÎÑè`yàm̱ö°ŸõÄ…úÉyÍ`Åj–¬¼BlÀR$.Á€ºöA¯à•8ऴOˆ°ÙCëhù¤ªoª’±Ðñrµ,–s+y‹hh2°FQ îŸöH«¤ÒÌáé1BNŠæÕ@ Q®vÇ5Ós/€Z5öèj΂–gžIž¬éÜDDоÂL?rÈûÁAÙ´‹;C\«}$ŒÔòrÍ=db£)8TXîÙLzÞ®²—O.ÏR b‹<ýõïŠë:«oiL@9÷ŒC „çABŸ?½¸z‰ó(R2wY&›«’iŒ@¬…™Æ¡!&š¦.†aHL€ŠyÇõ®ZÝL]LþѬEð5c3—:!­ù(ÃÌW4 aöWUPë|U4ù «2„#o¤R Ѻ·‚‘JTü1n¦Â Â8}#g›=b—H±®©Ák(–yŠMÌS,2O±ˆG½Î‰‘ÇEFãÿ!¥Üå»Ç÷õo `Tõ¥"Õg9$ŽÇ€DyŸVö{ãð<±š‚»¼ÉË'ÊBVínݶò$žóI»’3o!‡¬hÇsv]sRˆ_ÌÌ9/çÍŽ/Íi²ååx]CäW”ù ZšØ«KÏȯýùY-j¡œ¤È$FhÀU«ý£ßþ‹5t‚¹óJùÁÝ/ö#Ÿw‹·þÉÉäQVÅ9Ç4“4\¾¾zóì“øŒý§Ã-ï8–©³"ès@y]\I¹Ë¡b¯ª5—Î-g.Š.žÌË€/Áª–Óðùų×?yiCB¾û¨žZ0 iÄ1•ùB=ÕÑü‘r: » tG2‘ü‚|¡’JDæ3 µSwê¿Íœ` ¨­ ÑE†b›ê>\xÿaDá£T Õ‘SýxÌxÔ›ñ¨7ã¾µÍW!Œ9W.«±l'o ø@þÛŠš=$¶ Zë Ðs·Š+wªâÊq„¬&VÔ7”\ y„ÂœŠ+ÄÃ=+ÜjÏ3ôpH9vP'd6墎Ô0*Nûæ5w !Vgr*1—8ØK%LPæh¨ExÏv®“h™‹w‚‹ƒhÉv£?’ ¢lÃ9ˆa”°WL79&NWHÄ渣ú DZ/þgøçId×%õ⨻?ÁAéÝÃsÜuI|Ь¿ÁÂØ WõÎ9Fá9r‰²Ù@\ƻభÛçãoÓV Gcµè7§Ñ½ ßßkïücE2˜5Ô=ÌuBßL*õr…yxXþyIU½ÆÄ~铨ÐÄ·ØÜR=Ьè,ôˆ8L2!ŸZùñœàp²4ÜÚ˜˜3Ø1Œ/QÚÑ û@®ý'QÊÂòïƒN³¹©·dø¡¿ºËk0}T¿¿ÑÖVC ÝíÎ9é/@מ6/‰i+O*s…ŒrÁìiçt P©ù<§ewñÕŒ3ñòIÉ·Ø‘@ì2Œ´±æEþ›ãaWCµaÂç:MXk |ü§1ŇXã ‹ŽÊ“«˜Mw%RŒ%5[n(P@ÛàÎUCó…N*búìÌ]†L@ÞÞwQPó˜þCÀ}/â"@*ê˲LºçI™K}’’N­HS5oó‡0°ÝNð]ïN‚lì)ÚV»õ$ïx"B÷;¤Ø‰DvwøÝ}êˆL*º¢7ƒ«=Ù_+@XX[Êu@¢M[g|i};È!Ž? 1P…7d‰tý{ =óÞ‚“—ÀÚì&çÞF˜Ù4TñÒß½‰0˜9¤× &<9HúÀÀ"|¹q¬‹kdþ‘‘ÎWÒ›„$Ì8¹EÇ©j^ dº­+ˆ#×T§kÜ{$(`{€+O´Ì}RɸÐ.O‹[»×ºx,¬™˜Ì^É“û™ðÇAô›ÀßðSFa6­Í3`V;ÒÉ]ûŸ.k„123÷›‰îâUô/ƒ6”ͼéˆFÜÑ h‹Æ÷Kÿ b&BT`'»ÜË·”ZÉV]|ŒyžÛ …Û*dƒºøžø_xŽ¾ÈÊlwÛ„@ñhùœ u£0ðïNº‹xâDÍ7Y]ãÁe· õ€™ÆWFÕî=hýr=—Öa)=`@lìò³­0]\üJá©ú; (‡¶ 5¨åu¶º!ˆW¯©+¸¿bW´·9 ìùšY/_<½¼ÿA F²Œ Ÿ&"„µŽRàî•D˜8•D$šfr0“_â@Ì@ÇýfÁ$ÌÑ¡R?Z°wP± $LØ ]s쵉EöžRkœjÍk0 ŽÌ ½¼:éÌê)>#°±zj°Ú»Vrº6(ᘿ_·¶EÔ*ºkí‹_"l»:‹-S<4n¹¼zÃb®c+¤¼ØáQÿ>±^>yóxbUfö¤%hKg`­ˆûá“©HbšÉ97"賌ø †÷þcãä/méêÿÔò€0ÉÞwNÞ ; ~bøf -~;wο®É÷×Þ‘­ØY`œ"y=ˆ±ìêáØkîe_CEúo×4Ž+º)Á*ê_Uæ¥Ê ŽF §òæ‚ñ¿’†¢tÏ6†nÛÛDc#²‰Pâ<6=¡ºÏºÛðTÇ’ –Ãzh[Auxiˆ>”~EŽ »>/¨æâgo× ƒ0ŸƒBMÎ!D‚–n³q ç£ís“ iÈÕÔŒ¹ uÏŒÔÎû'"Ž¢}íôרAhÁù‰¤ÓŒ$tçˆdÌPç Pã뉀ÀS¨) ÈÏ`Üuz‡qà›Ô=à[ãÄMiàµgM»•°‚z€Ý[i„”ꎵç ;>vɬ¬SÛdþð½Ò¥ü®:¥KM÷ü¡Híäùò(2 0ò³UÎ?–¨ÖIåôœÊ‰S ?xÊn5={€âm9=³£O€µÿµæð endstream endobj 1247 0 obj << /Length 2561 /Filter /FlateDecode >> stream xÚÕZKoÛH¾ûWp ЀÕé7ÉYÀ›™Y$˜Q²Žfy(‰Ž‰P¤–¤&q~ýTõƒ/Qvœxø f³Y]]ýÕWUݦÁÇ€ÿ:£“߮Ξü"’ &‰Ö2X]L1¢)t¬,Xmƒw!;_pEççV/»oƒw ¥t˜Ù.+Û´€1‘¯«z—¶ä|!b®n2Û ]uþÛ2ÜšÖö®ÝÛ¼ÜZû2/mWk¿”aÓÖ‡M{¨ÝÐMµÛW%Ì×Øçå…¶üù×󄇫sh_ØW®çõêêõ˜$,I‚£$Q‰]˜óŸs&Txyua×™–[Û¸4 þyuöß3k¦ 8W$f"Б$"bÁfwöî ¶ðòe@‰Hâ೺ 8Ñ 4ŠàÍÙ¿g,ÍyLµ’XÄG ÙéßSE›,sV§t *¨ÑüþáÊì~sX7٦ͫÒ~¬‡?1Ù2”Ɉ±Ç"fD‘$‘ÒÎYž3ÞZìBm›œs¦Å!kìóç¼(lËl"ü¶u–¶™3\ê†Q2šßÿ>ùEÓ%èX‡Ÿ²ëôP´nbœ…L¬'Áx7Å|òðÆ`ºÞniÓd»uá²°ÄÅ‹B '}¤ÖUVô ܧ5*Ýe-˜¦nftŒ(áj ãÝûøä9Ô!&´ÿöÅóåêW\‹O®áÔZ¢˜ʧkÙ¥õ§9€"»2&Y¸\¾µm\Øsì`7 ÜS©DýˆoH3‚D¢­.Eµq: `CËÅ:o±Í€8Ú wäcV7ö-šëXí­E,ˆbñ#¨-bM8ïÓ[ð»ôþ„pÊö­}àZoå"!TDcþZ§›OŸq|Z;`"A¦m¾Î‹¼½ÐÙ±ÓVë¦*Âö)wÔq}p„ íø=m²¦ç ôV*¸ØðÚøAE†ÂGÓ2-n›)@h³ C¾D(q}~ ý‰ùÈã±ÿð7ãJ^™ª,n’çܳZ^¤@¶ÍmFšˆµ1t‡ß—î««À Ë*~Õ[ "†Øuh\3-íæ1&H³ñæeu]Õ§v¦Nóf@^¶1Œµð8Ðѱ^g,…kÆŽwÍÇ™»$mÒr¬ŒЈkAßöç_½š>òØØ ›ªi{ÝÎ!é7ó.<Ž ’% hg˜‰‘' 4À­©:9ÑT~ @äåo³÷”òÒ›®[;ä-©óìÛÉ.vc¶9ŒÊ׈ÄC¸«ëÉ°õ»<ÊÙ´ßNú$ðÙ/:Ü-0½1Y’& °uñ`€KÀ%LNbpºuÐ]ßžÄÄöPçåÇÉëw`”ʼn¿Qo«Ë(ʽ>­š&·îí³‰¹°§"BõQ¨vYÓB@ÄX6½#%¾oçòs6ßçD?˜²“é`ß9áwvïBE“(JزºBÐÿ‘o-w&n¤£T^:œßw&‚N£¶¤ý ΠЕú_• çÛ#öP ‘Ž=~ûý·×oæ !Uv®\g \Ù8évÚ]ºß#JmÆ„.Òc·©s% 6¬1°ÕÜT‡¢]ÚÖÀD“/½°ÀÈцø0bŠÌIO«ê­ñ!#¥:’fu7UÙ…a‚I¼‡Và•‡]AÁ‡ˆk“flڪο¦=®Œ‹>>ù7àsÑr”òûP*;”bkŒRéQˆJñQ:zï÷H:”Ž^Z”b+õ¿J¡¨Ð-£O¦[{ªTíæÕQ ©µU:SL!°£)\r+Ìì;X/²rU7nlk‡m*}ˆƒÃ~š7Ý´¦QŸ–Øab=ÜýH˜€ñ± áRq$œ‹R4 sbŧ1.°ÇzMæ\ÐSì­àjŠÁÒ·´ ·WnŒ‹øb 嵕bb·ýÈG?/âNxãÿÔAƒø(¾:}FÖw4 ñhàDTþ¶PüW:B€ øQ­~‚  ®ß‚ a™/6dµ† lf•3Ž…cÉ$j±à©Õng)ì»}à® ^Æ¡@"£Qx¹«0â+ØÆ]/ÐàÙ©:ò¬Á$B17‰m üááç›|sc{Œ«Â/”ȹah›8 ¿L]šÉðÕ@8(öA²%è×õØ3©ëÍ k²NàL|ßf{XÏÀùº£é}ák=ÿ›Ã¾iœ—æíøh =yBЗX @ë>+áWê8}& ŠR>yæ£ú;…¶¯"'0gà$1Ôo'>)ü¤ TôÇÔÍkÙvšHÆ$’òŽ*t*{R|Î%!*é$ŠÓñ1¼$QÔÏ[Z-iŠºà]x0+@³œf§îä©æKºÛûJÈW™~À¡lnw@EñÙñEÜQPúc a&v¸œ±*¿fuåÁã~?横ÍGJ·Z%‡«B\k °5îÜìÒ m5Öyí60.DÇ*€ê5òÕë{*Ý6‘Dqk€¦CÇÎXvÔ Š$QdJÇó8:2é8\¢Ï@búÌ{Ž(—cà–'ä1!„= ‡–ô՜Ĵ®ÓÛ±zµuY?ÇÖŸ¸q¾¸ZÎÁx3Ò],}‡µ8Oç ïKÙ%²kìÞΈ您¨#Áó¤˜ê}Í. -ÑT˜ßØ=Ç昅Ë#€0÷šdSSsÄ`Ø—Ïÿ"æÎìqÌ1L¡¥†àòÿÝ ³äEY§ÝKH¶z8Ó°G6ÏÏß)Œ=¦fžPÇT)(T‹«EÕ§\ËÊ_ñ´7i;á6w©ÐÜG¥÷\ tâèÙp´Raw Áñß œZ+{ÓÛ5¼èÇgÐk&óÃE&¾ß½ùéùÛÝaßä–á-ŸCÁ¢‡Ýòf où¬$Á\îðfuõûó¹jrSÞ%r7U±µëiýÚûó¤ØØÐ,~˜K r0{ yuMîíeÔÓÙÊà“˜ë§Á©þî°Û7Çvb*‚t!Û‚8ÿÛP¦“b¡$ÉÝžCÕû÷™¼™A³Ï›—3†LˆŒ†i3ܜڋ>á.ú02Ûcè°´ÍëÉ;gú™|”Ãl¢›írF˜PÚ%¢x¸£´W{ÊÀI_›ücŽQ!=ÓÝÒ)ÔŒJËðEët4ÿ-ƒj¯ÖMæ^áÝÊh=îT ºLµ =Ý+s0i±C!E¦“2az&W0Äœ¼hÇÉ|Y¹Ž´h³zpÏ3ãž\%Ù½§ðÚ\9¹Qäøn¯O#s3Œi WÎñ¸}Xþï' ¢ endstream endobj 1182 0 obj << /Type /ObjStm /N 100 /First 998 /Length 2696 /Filter /FlateDecode >> stream xÚÅZÛn]·}×Wð1yá!ç `ð¥N]ÄØnQ×ñƒâ©Ñ@2$Hÿ¾kñÚV,ŸÔ[;€-pŸÍMg†3k ™³§BΞCVgC‚Ôñ‹KƆ×ÑðPJf£„ÚGŸºŒF 9mßõ%¥£œ ^¨qL¾°ªlIÀï-äË”ø—Þ‘…áÿ”‡›5¾æZé\9IÆZ…¿ÉØÊo4q\O²¡TMÜ'‡\3uè$‰ :”&'T¿Òדּ¯=Ãq„ ˵Q542œ«ÐRÃ}êÑ­[G›çÿ}{6·OOÏÞmž½ÿéÝxþáÍéŽ6wÎÎ>9ÉH^mþºy°¹û2‡£ÍÓ“×ïÂK(#fˆY<ÅDˆˆð;ƃ˜ÌÐïv¸u+lž…Í÷gÏÏÂæ^øæ_¾9;ömøî»#ü[@Œžb­JnKÃVöHÂo¦Ø+FYPŒÒb…ã1-bŒÆ¥”\#ìµWŠºœœ±%F ‡´ÛÆÄb-ýJ1î>~øð$€àkMb‡7Z–ت\9ÿ³70½ö;ÃÇNí=¦~µOn?]N‰áD-ÅÆho v‰r—èÕîøðŃ{ zb«±n„;B—<Ò Ås½Æßÿ4½QcNKîÎN™ U£ka W ó“ó HòèïïüeAË(ö‚!NQÌ ¤«}¢P/Uã1GYP70!À áKH›ˆ£=6¹ÚN{|gÁ½Ò.‰ ½GlÆsEþ`$k×ÄŠw=ÿáÇoD~üvAÃTLˆT‰l _1@%( h b;dYÒ0Ú dJ“h™± âx.z󖨌B„Ü[,HüC@Bd’Xó^ÓÔ%-cª Ûå€bÀÄ>9.™eÁ<¯™á‹Û„À[‘߉Â;žË 6iyd@ýØÁ;LÙ0óÌ÷e]è‚vñ*m vQȼ±ëAøX•‚$Zrékä!‰Î¢(0k‘myª ¢ qšYì›(\õ²}\&› "FÙm@«®U €•Ñä}/×ó%÷en ™ÈFŽ8QS¤³"!zųïE®b‹’N@U©ä pDŒÚ/Ç£û¿‡Ë*E§ F$ Ži-và6GîGY‡×RÆ€•2£Û®%€ˆFÐxÆÊ‘öŹ¡ Èf«+h I´ζ¨ÁÖ¶ž“DxêØ  ¸ U è@RY³¢%ø}×X;Ó%¢ƒ+ ½ó ,ÉÍùY™j²ÞüVddÇ)€5º€¯¨ÿ¦øi[*BA¯«¬€ *÷ôQ´#°ÃzH­ëã€9vÄÑ]x”çU¨|/Ñ Õ ¨…h†í"4 ûpú‚†`0·Ž=‰ Ô$¨„(%¹­‘þX–­=Ú¶J-u…é­jäu¦…ÄCòžc5X•C¦'–É~¿T/¸Ôq²t³ ä‡ö†ŸßÖ[j-÷C{'‡2[”–+×Õ ®/\ª$|Rø]ñ@ù`_W/Ð+êú× xM`Ë«ó¤ÜyRî<)wžd^fg™d^&™—Iæe’y™d^æÈ2G–9²,Jæéá F*<°#òyÏ  7@À›?<åÖ«’ÊR»æ±õü©£&[ƒ5c¢0^s´qrÙc†07¢® €ol¢`‚ÜÓ {çå„k°c'Y=xAеAÓ$òŒŒ·º=G¿Þˆ buœÍ)+üÐ7‹ŸøŠ‚Ф³ ÔF]CAÜŒçì‚çró®Áù˜†Ç6aJ¦K0- GÙG󢧥Ò|D©p²õèÀÊfíbkú(¯ ´‚˜ Ú^9–µ²^rÌ_€\óö~ÃÐ ¯Ù";5,ª°Uð´q6\‰ŸžÜ¶è±ÚÞ£Úe +bÛ3êœÆ- ^™­{ÅÈ‹Ö3´#RÛm<¼WÞqŒ}Ü?#żzŸ¼=>?þåüøí¿·‡a—¾¾ Ú“ð4ÊGøJ‘w y•ü aä3l©‡bK•?puuï DgåÐÞMxQÊ{‹RÙ“çƒÎ¢.aËK¨óòYÔ% é¬½]yJ…MUçh4ù:jõsj~EÇþÕ +uDQ'ô´ÙÇ&ô´ =mBO³EÑdTÐ2Nb¼!q[ñšäžƒ˜ß»¾.¹™$j(‚tÉ›,O¼W@Y¬ÚzñIRGzâ± žmYnUyB¾º·½l äIx¾#@ò‚ Ø𠵓ÿ¶ºbÄæ5+„Hë6x,z=1£”µ#6Å©ãš> stream xÚåkÛÆñ»…¾Ðw›}“lëŽÓj7µ/('(ïŽ %*¢äG~}gvgÉ%EÉGÝ¡_ ã,rŸ³³óž!ŸÝÍøì»güÈï××ϾúVe³”eÖêÙõíL(ΤÒ3›&”˜]ßÌÞÏWûÕ¦¹øåúûg¿~öû3sùLÌ„I˜HR7V©Ùrõìý/|v}ßÏ8SY:ûèF®f’Ù ªÙ»gÿÛÔd,µiÓM¾ýîùÕ·ZÆcáQàbnЛ7?ù1½õ¤`Fê0ægnx¹ÞÂÌïŠ-¾¦ðŸÀ¿‹+™ñyÙÀošÍw÷…oXïW‹bëë[j«×ÛÚ¿ëݶ,hÚ¢(×w´Òz³ß]âsÖÁfD  85Iîo#àg,±-ôœ]\i™Í_íü«}³ Ûú–¦Øá"3xQ0SÌ®g™ÉüüÅgeÃÙ’ù¾q'ƒ¦zí[¨ËÎïk·64-ŠÛzK­ù:¯>7eƒ€îÐù¦ÞaÙœ¦!w›Ìl¢™JÄ#hDY ÃÝB"‘SHdŒBšÇ)Dø39Â@TMMO’Ï?\H3ÏË*_T„TÀÝΘ4ƒ+È—¿}¼|žoo`8àpY¯6ù®\”U¹û|aÍœù= rmˆ( Ò5äծش\«?8ðQ¢U8Öë_ÿðnŒ=,K³?ÌÝÙP2ÀI¸b&Éà(puR>LÀéyö’@§ãIðêí›±{†e”cò5bÏ¥U©2–qóøcH-™ÉÌÇøþåè1+Ò!W¤MMô’o·ùçåP"ç7åªX7¥ãvè±D/Ëz½ËKêñr@ÊÄ—Ô!Í‘¶PÀz6ëÓö²®ö+œ¯ ¿›rY¸mU:ßͦXîJ\ê‚ZTŽÔ]wæ8ÆÍò»ÂÃ*™úÉ?“|‘£¸™_ß»³¢$S6H@µ ™(]—vñš$ìàÉ_Ù®‹„[Æ ;<$ïŸ.}ÈšÈN@NäP¸I‘> ƒ «–T=ŒA…íó Y3°_Œœ3e†'1U¬"Y–¶”¿½é¼È«¯P€Vŧ‘5p¥ WH⊖E1dÌ2 D&­'2hñDŽÈd`ÙjT[ÒRÍ~yO{ú/þÛ‰9iìL3™&}š{ˆø QÊëø%ÂU¤}ª½{•Þ>‰û‘w>Óܵÿí^@Rö¶$¡«ãf…’hÉÁNžc“j¯·°‘ØS{ÊÀžjŒÑRh=|~ëµÜÕÛòÐ^hñùæ>ohD à΀¾™™m‘%ÂËÛïž ˜.µ ÈL+aÿùu¡†n™h¯ç2ˆJ>wò ~[Óžƒ|@ŽÏÎLƒž S-?=hå-ãÀz-¶å2¯wÛb³­A07bî-U<ΦÃnÙñÂÛôÀzÙ¿ï‹fçÄZ¦#65ñIPs¶\'FìÞ„AËë†&9¼µj^½|sý„Â:ôÖÛRæboÏÔpN´P%#âD3ËÓHD ´‚µqæ°á DM* S‘ €ÖQdÌj9U¸õ¾Ùo*¸Wo{ëÈ ¯à¡Ù¯V€n<¨o94Kóªòšª[^>–»{ÿ4†X~¢{ö»«úöj›¯ïŠv,ïÖÀ/7ÌC‘2 ÚtS‚Ô9Ü8Áˆ²Y/¹xÐäð°ô€[/† ¥ù È—~'Œ€ÊGÌ: ~ˆYfôžÐ~ „9eÙeÀ…@ŒÆ€…×W\§çžN{÷Ÿ×C"æǹ~„T@³ÛˆõnÜM®œür(Õ`UŸ}ï}^ÝöqIh¶†¾¯÷Õ^P?H4>”7í•Š ¯£G\ßâ(„BebO9ªìKôf-Á‚}ngnlåuTAs ¦}•Ó;;ÿ„0ãš)Z˜ñÙÛÆËjã$]´êûü®‰M¾VÆ[ÀóýfSlÇlÂ0D«Ì!øÖÓ®G&4´Èz6µãú€áË|í»4$Æ»o™FtÆ |¥©ÀËi» ‹ ÎÌ÷q§"oãá‚AÝ醧¶3L¥±@…Ý^{Mîð[,˦uQaƒ„cY¤&’GÚ^™ ±¡µ§™6-|9±/`²$±ci {À™õ£Êr4(¤ ?åí,Ü}Qøß>¨,›çïélÊç#0 ."Ô<Fã½Ônr;8X±&y+1h,xºxcÛ(&:”Ò΄uG&\äåÖ?yqá~A¾Ü^µ7çµbr\bftÍtà§\LÄÕ¯#¦GÆtšÅ¸¿ŒCLÚì׋+“Ž¢ žÐDRL„—2‰ ƒˆHÁ“—5Ð^€Qà|‹4…¿_ )àK›Øóulï­=²Aƒ‘¡äJ’I2ÿ}*Z71±e‰hW­ mÀ6¹òqm“£Ï”èù‹» $®/C„Y2 Æi…ê´³ûd°ûD°³¨Õáu^l2ÊxªS%™ŒhÙ*ðãÖ¾õZ¹tzNsDŽâTVI“WE¾&B XxGZ5‘‡¨FWC)? Š*4L¤OÈ@ÃMƒKÞKß´ëÅŠ>–ÁØ^Д€óñÿÉJÒ1ÎfkJqWÃ$þ»üq>ÿ¦làŠÞ;ÇL£çÑ4ÅjQ…×`{èžÏÖW‰eZšÇÊÇjŠÑ Tm«'žsÚ7`¾·¶’à¿úl"=¶68]`칸”—j7€®uß —j–t,úïûbíAÅ;ñš]’É&kk­À+IÈ97Þ#äâëm½]å$;§›ÿBHðG²ãx?fÁ¸ è|Œ{ZI‚“– Â|¦6üºuã\ÿÆ¿ìj?ò¦GSÔwO5 >¹ÝÀú)~æ\®‹6¨ùÓ‘Ä1%=@øÔÄ ]rðÞ¼‰=!] ŽÕQÔõè‹ =®˜¯8ßR&.°j• ´ÆÍ© 2fº+%‚“­“ÂÕ0½_îö[êBbÃßýƵ Zã„v´Æ'?ïíУp EÌ|ÇÍQ`\nÖk7z<>p@à oC8 ½á8ðdFby$o†âËÅ –`p5ƒ)nUo›SJS‹~žêg.’ßVkÝ80–õ–\4„¤¦æcØlÚ¾\ĪŒÂý}ØãØà9QKɹ‹•œIëƒ@áåIŠ—¦$˜JÌjqëá"åHÈû«rÐ×Ãì"ÕdLûhÁà¾9,eXbÔà&ˆ‡rçólŽ8l›^vY¼¦)}VÚwÔz ›»d]±Áéùк¦UC¶³ÍëuÖŸ¥\æ ×ÁNq;,ˆ6k³†atUS\Ùb dS»fLZ<2&vþý©.&ÙÊ'gŽð¤GO:n‹e †Úº•zmÜ<ÞaT¢¹hp¹Nµ@{dÑàøV#ë‹XÀ0ÜF)O7‰tÕPl˜' ´T‰ j*"NÊg1/îÐtDw¨µFÁþ±tŠP5ª5É!l 1NlÝ·¡yWøÙ{7åÝ~Ñ`’Û)j˜çíô>¸4Ô+ìŠ%R`ì`G¥`êa¼)²Ô®B5 > I×;‰ E†y(4Q¡š„’¨ŠY®ÎPHGJˆ=¾Þ £Å•“$@|I2©ÞKZÅ\ÓÐ0¬$xò¥Ÿ‰+ýD½W6=}iÚÒÏNåšÎnªöT.˜ÖYÖ!u\’nð«r‚Ôx(;‰”8V[jÁc8]Yše2â ÑÔŽ84àŽ]~—?“D¤~”øJ2::}tE§f‰ÌNWtJØLn£G+:¶>¨ÞTÇ«7¥ nÖ!¶n(ƒ³|ŒÑä)†ôŸ!kÄ]…µ ŒìAüw=p,©pÍðQ©BÂäv¢ÿÄSFÓ­/ÃAOwéi·û \@9Àô©ž&rd¸}‘ƒrÑ&¯1׳ã* ¶¤GkL5 L>Å9¤á+Î9Çx‘©òHÓ£E¦x&WN‡N½ÇupqEv·uŠG¥¦ØC‘¨¨ÔÔ-וš‚!môÿc©éyü«R–vjï±ì{yÀ¿#対D!ÊhÜy…áÝÑXþùudX~»+¶GBgGåE§ÓIrCdÜe§/7p%—Ž˜jª ËR qu`ýYt¤U0¸‰1Y…5ýÉC¿Œ¡|…ÉHJ(†`î…1s—lLè« S‡´Q—bð{­IC&`udýâQ_ÈfU.vï>h VáŠÈ,Õ²Æ]NÅ×Ûߨ@2„Ú±kUßU¦/ªª¨ÊfåÎxi ^ÛÞÅ/Þ>¼,U„ÌOæS^ìXС Уú «=]ÍuOôøò¬e±quLá²…(€&‡É¸‹0)ˆ â®u½¾êcz»¥6…h§ö± g`˜ÓÈô,l¶y4‘u&•±HFLÉW2ÁÆ +6M4«îD(›…šcdKÊ»*XÆ1¡yº1‚ÎØó´É!ÈÂÿ8m¿’ùO¦NxZøï˜Pvgú1âh)™V~¥ÄLö1`àX­Ï«Ÿí†¸Ò=°Žl :Çžrk¼çD÷§Gkmœ›|>îëÄ‘ò‡~©vì‹–©i¡¤c’'PË°æË&›óCµlXbσ«¿èwmú`¹cÍD•w Œ:ê@+R=æ0맄:s¡°³`Nrñ¨ñÀÒ졨“Ç]Àbû2²ï¯$YÏ_î7Ǹ^ÓE>ßÈõàÙœ‹|$Yð>’çiŽu/zäCLmÜUõÂ1žì@W줬‹©+–rê”4·,Áx`4¼óÖ\âðÆ?ÇL¹Ä&£JÍd] :>ª‰z€ÙÁƒµ«"%D¦úËÐÅ–ö{¼¥m]øŽñ]‘œ£„gõ‰÷BÛì»Héa¡æxtÁµ+8™bKr%X!Ç&íð>þ s‡cy endstream endobj 1306 0 obj << /Length 4225 /Filter /FlateDecode >> stream xÚ­[[Û6~ϯð>,àAc•wIYØ4h‹étv:ݶۭ™Ñƶ¼’Ýtúë÷;$%‹2íÌ-ƒ@E“‡çúCŠMn'lòý+väúÍÕ«¯¿“ù$KrcÔäêfÂ%K„T“é„K>¹ZL~®v«M{öÛÕ¯¾½zõ¿W¿e>á:MxšÙ¾RNæ«W¿þÆ& ¼ûa™g“϶çj"“ãf9ùùÕ?b“ê<ÉLNº)š¿Òœ_§Ä°/n9 f;½‹P…AÒ<U£™²De#ª–õÜ5Z@"uGÓ˜fÂE’g¦ëÓœñlZ˯çõj³,ÿˆŒ©e¢eÚý`SWëmÙœÍTΦEÓ÷gFO_ŸÍ´fÓEµ*×mU¯Ýëóó²E¦:É2ñ|aÉ4Kt*Ø‚es7ÿj×nÝÝu鮋ò?Œ‰u¹èšoêÆ¿ÚÞ•Dìd&$Oã“gI®s7îÍÇrçÛº©þ,¶v…Rñéæ®hKwÛq:Í,6Ñ“†”»{¸üžäÊ HU’Ê^ƒ~øéÿsgcÉš„«®ï[áIóv¤Ë%ݰ馩çeÛÖMë^T7#+ËfD7ÕŻ˓då Ï{{ëfäPiä´X/¢4òlZžq=ýc^n¶î= ÃÞÜÕ¡ Ï1•4¡X»¶4I¼²,‘¬L@ÁY²  WD5ìZ²ºsÊFwméo"NA­‡[32Q\Bš2,É0ÅóISA‹ü8iI 3Ýu2“?€%̸ÂõaáJA£Å‹Ä+…6!¯~|wqñáüûˆ»W&ÉY>Œ!äðÉ>o­Û×:tûÌn¯áö½ÆCÕÒUM›r»kœãEëõ½§²DÉÞ>üåÇ‹Ÿ#äiÀºI­~ÓõŽÌ TΧéåˆ6óp?aè¸.–÷­¥Oާ۶ɠƒ{®Ö‹jîÝ?=×7¾ŸÿeSÞ”Mc‰_­ŠÍ¦ZßúŸ>ÒS è·Ìïϯ>’0xfy{Âqi‘ ÇÀqÑôÐÛYššéOùö®Øº»9Vûºã’æÊC.yM±Šà£N&¬§ÇåÃÅåÜ÷OïÝãª,Ö­»uÐ]¹Þ6÷¾ûåy?tGA©`Ï£¡Û»z·\¸{ŠÛtE¼ ü½Z”þ )î‹$îñsµ½³‹a~™Ç9ÅúˆTC’…ÔÎÿ¡Ù‡ÿ‘ ‚€à_ÒHˆÉú^@R«ÝšôDA )d€Ï—åªh>u“shúÎm3i ]&küœ–J}âÆ’ƒ´ü‹Æ"L’å½5¿öã¯ýÈëÚW)àiøÈ>0ïL¤Ò‡ÜØ`çW”æÓ[×ü¹¢°Nw×¾ãMSZâq»Ø5ÖDªÈL¨i^týœ"+ÓYžê8Ó¥êí£“ûà ŒâûƒÁæÞß:âgÂóáêÎ Mp½Åª´ð˜Ÿ‡¬7Öy<ŠÐ™*QJ‡ÂyŒCž"4)¦djø¥çOoúBóµ&4_óOŸ-òmî¥ p€×Õ²ÚÞ»N–õö%üˆß«z׺w¿“Õ– ņÖõ¹>@M[÷ÚÏ-)ñ[§òV-ÉÁz{0àµM;PoñÖnƒ_·m¹!Má.7;Dßµ)—%ü]âfAZ…à9´HHì4ÿ:ËÎDž¡3™ri'Æ£"nv­¿!÷o¯Vªí#õLÓäOpðöjoo “Ҹ«t—k0µ'—qÜ»'Ë{‘§ûu­lä¤;$IÒAòêzY‹ô¬£œ4•Y(£ïv kVÈ©(`uºÙYÏ$û@ ¾ÝŖÒ?›VúßXIâz[®Ë¦Xú·~Œò†”ò¹y…¾ô‹,¯Ý`ܪî’ÜòŸZUÉ]Òæ4Ë&‡v裈_àSÌW ¦¦ò©bÞ;ŠàpxÓw«ÚúSCn¥¶Ü5·ÖLk×îYýú‘ ɇ~>¥ÒQa"‘fE†¶¢ƒÕ±.9¤÷^íд.`©V̆|Ÿ¢¹Jk¤Qd‹Éã–Iu¥ìÌN8z´‚ûz½$Ÿ`lq‹#Ï¿þ³o\f‹€Ãe&©áŽt×¾q=眊eõg7ÄÀ™úùnÜÕ© jUg[ e#]Û¦úÃ{ÇeS‹ûÎUŠ.3¬–…³y4×ëQòèÀ5Ýíq—4%Gò5ŠRïnÏhÈ5¹‰ñvÛY}3»%Š¹²à°*[÷àÂnªÛuma´m]û›ÅÎqìäOÛ\ö"¡ÄDX´KˆËÛj¾[ A?OŒ•ˆ?žGZ€ÏƒøYWá ›h$#ÈFH?lYk†^¹ñÕ‰ÿFp ‘N†½h ©c\´\×6²¦.‘@P¤©ÑäœÒÃÄŠœÈg•Õ„D8ÌÝH\ª0ærGzÍÄE¦­ò— #Km2òE:"U‰ØÊDöTH3âÙ *|â!Y³Lm6H²òâÚ.|§Ì½Dõq‰*ƒÜž¿ÀT*࣠Ž.Pà·JC=ʘ+ŽØ/'*©~NýBÙ 7ÇH1âàØx¼¼.ÀþT í{NPáe,s'c\ wÙËÂSëü1Zæu`º©× ›QÓz·*x±¥{TãÜÖ-ìßù><?ôH"c‰é+òÏòE†™_„yûb¸Ô:‘…ZKðÎ ä¶1ñ0S©iŽ°iž#AK7’à&b‚ž˜µ#æÂ?;S‹S'd–0Ìò|ê„bI*ò8u"Be © Ë©©X¶µëÔÕOú 5V[×âºÃ¯Ômë`¹íWwã[ìAU( ÷iÍY¹gª%,=jçf:’fÌiu½ô¡Ôt“ Ò}:-‹ùkýñâƒkÚ«<7]lN;rÑ4ËÃf ÓéÔ!­²ü µ{ߺÔÑAkxé'5ݤݰÄÜÏwÕ^Ü–5Àÿ»®€ƒ$6Ó±g¸Kqçž+É · Wð÷¢K˜mŠkKð]QË'qƒßz*;¬è’ÜzUHúj4°ÖA1ÂõIƼÌ#á‰gÈ¿]–H»·6ÐùµfÃ=Í0wI“4=õºÃô£Z¸’°þAjåæ!eŽ ÊîzÏÆc‡É‹,>Ot®vžÄ¶rV´ÏÆÖŽF/Ò ‘a¹t[6%Õõw ßÉ¥îÅ –¶qbÉI.›‚7M¦2œi‚«îXÁö)&‰ÖýÂkB寷ÕÞˆ×~QÐÞA=5µîvF¨Jdƒ­ó¯¿#¸ÖÇ/xg :ƒÈäY­ƒê, Ù0z½uiHj·ƒ‡†MæE¬Qºiø@ZÀIè‰HÒNfÊËU[,ÂîÆÌ4$—w=‹P÷œ¼ þQ Ç^eœZ÷’÷×H'ë®FRÝ&XÌ_"#·°Œ*ciæÅô·ˆ8ÁjM{¤ Ó‘¥8"ËcÂœHh¼pkÔ•%;-K9Ò”ïmùaÒÎ{)Ï?¬£u]b";“Ãí¹‡Lh'‚Ï;ý²Ÿˆ®,¦/®Òè¨Â¨ H ÖJ:5‘"e¡:„Œe‰6f_½<”m3këws_•e½x¡p]óM×Hª–EÚÒQm:û¶¿ÇD‰yûh3'ç_dovÜzO™ç)‹a”Ck>õ£#Ö-#‹€”­=Y5K²t¤ÌOÈFÔÆôÓaª§ègJ;PæôÄÐWd…‚Qº‹ÑÆΠ<ï#Êó>¢<ï#ÊÕjÚ9Õ´°TšXIŽ¨—GÆŽûÊôTܳÈqßé«è\‚ëÇÍ%FåÏ@°3:pÂcf@8FõÞ“§§Š¦€:ûbëù[ Á¥ çß~<ËÅôŠª¨®áŸg\"U»|kbqÎ@)9ZÍ¡[Ñ'ÜJnGšˆîœÄE$o¦Q,>I”ñÝÎ ”fÓoÏfZN?^uú‚m^oªs¡ÌF æášàø3ø7 ½ P@Ðað¬N ‰Ñá5„nÚvPùÄå%— Θÿ‰—ÏÅÕe„× cg½4~¥-°·ï7´¿Š)3Ißõ·8Ö|xŒӆ¡?"¤Ü%õé-s.6ð!~îN¿^b9'Æ’|èÚbëÜs•Yp\ü"õ‰E+À[ÎåÏ­¾ Kè$ãKcˇ&eâ ¬Ôù!/?ƃߛt”—‚*ó#VÎB^FŸxÀ`~¢§ï2TD_ò“¦É¦µPv?!•OpŸîIûfôƒ ûÌ!s-ë¬_szµçò^·íŠü±Ç½7 ÔwoΔ»Îø)zfnôà´ú ýÔ,ºÚEW‹ð¹g$m¡ã=»ªØÙ±„ï«)o"#Ðfm¯¿?G²Æ:òC‡jÄbpé+°WdS¾/l„ørÑ:‚ìø1Ôñ¤5é¬IžZS ãȦn¨ŸXq’yýTÏ0˜ÁfÜñP™Cä,‹Ó©=A¸¢ïösWØSàT8 sÒ@EgbÅj­Ž›ódŸJïù½[·÷«U¹mªùþn·1\”Qø¡yú¢ž`S« lê!JÿA="b<,…(–Žðg¨Ý‰a}ÜQ‰d*8xÈâõI5æ¹±jÿtEn·uckËWÛ†«BHõñ?Žu?<­ÝúòFŠlö…X®´Ô2•?¶ ”žÎwMãNð(ÕÑro,î¾þÚ=îÒ×+ÑÓÒˆ¶aIÍ´bÏ\RwwR­×~Ôj½Ùù&ê‚Šø–€1­ƒ<þàcœÃºõѳ(‘6ë ؘN`_½zú‰æŠØ᧋ª…Xüy¿îlÞ¨ÒÜ‹ePD¦C©N‘œZ,Q9vŸ3$gF†¶pì,>’Z£(÷ý?(g‰”4yšGÅ?%=<Ñû3î£Cø~_ܨüت„¡²¤zU ßmTtU§õìÄ‚ùÃ1³Õ?ùdHÚ!ÇŒÏg€Ì¤-¸¾$Âäú¨a8Í~ˆ¡MÞŒç·Ó„‹ñæîàS !³á§È §!”÷}Ž)•F&HJÅlh|†Niª7¸ç/ÊÓaj~Œ±¡ZÿÂ…øÒåH§ä¿ÀÃSÉQwXÖ “}WaƒóLJ)ìÑÿÍ“<.:wK‰TŽO?çC'žóDr;A´‘Aì §SEæIô†_­rú‚Çô>ÄÐ)óÒ_Ä [æKb³ºÒÊ€–^žþLPÖƒº¯ÖîÚe´ô…¤kq‘Ž1¦Ê†T§HLÈFŠì÷»õ›z½nœ‹E ;”éá§$cóÏìw¡}çöØÏ™CÐÁ’TÛXÞeW—¿¼äA‡ˆ> stream xÚÕ[Yoä6~Ÿ_Ñû°@72¦y‰¢Ì“ÁÌî$s­í$X$y»ewOÔRGRãüú­b‘º,m°Ø7ųH~õ±ªHóÙåŒÏþùŒßòûÝÙ³ã7*™Y–£gg3¡8“JÏŒ˜Pbv¶šý2ßî·»zñÛÙ÷Ï^Ÿ=û㙀¶|&f"Š™ˆ­««Ôl¹}öËo|¶‚²ïgœ©Äή\ÍíL2“@"Ÿ>û÷Ô Q¬±ÃAwiõwóø–ýºØ™«ôj z³,Q¨ð+ø¦h²…ˆæ—YŸbq$#>ßÔôÛ¬3J”Õ*«|òbT¶M›jó'é¾4R3!Ã`/'¥áÜ„ Ï©;/u$ ÏDÒÎë=%Ló¶g‹#%øüm3œNQúŒ4o²*[ÑÇùµ_IÞë/6,ITèðýï?NŒ* ³\Ì¡` £ˆA5=;š%Z? 61€Äš¯èIØøܼ~·HäülzÂF‰;ñ£TâF0Qì·ç ¥ @˜—åÙ6+_õ<Û—¾u±Û7€eÄH–($×Ìy*è+·}XD±u°èKé`‰N )XÉ (bØKÎ’(ùðЊYeC‡ÖLÛ¯Â*Г´útø ùtv21ce™’æ|àŽšù®Ä,÷ÍÓªJ¯ÀíN¢ùj¨7eAÅa÷¿[ÐÞí”ÕûåšršuÚPª“ ‡þE4hí«—(øìÈ$°Þr¸“X‰ êMCrH ˆ¤\ßÿO ¡¢ùË*tx†Â¶í¯œËªn¨ôËBâ47éyî‹7¾SÊüŒ  Õ<-Vƒ¡üTn,´ßîkßøÜ÷\g~P?E>19iMorÒ‚pn;° ­‘§Ø7–åÇ2wØèfe¦z¦E<ÿP6Y¨šúÃiùÙ`A½.÷ùŠªŸûŽ³?öiî%+©H°©™½~‡p|,×[8<ºsêiÊ,”bRÛƒ´9J€UÍ×ÐfìICOks‹è •ŽA¥“[UZJÕ©´ìõUZJÛWi,¾×ØÛ¯RJõ2 ìØä8°cÂAA¿ö%ù¦nj¯ã0 Áâ𛨲kÊ EÔUÒêhˆ†3ÁP¾ñõ dP¯äN‚L€EÁU|(Ê\‡g$ΤÈe5•r?ÓOZù†uS¶âÿ¸µ‘\²Ä<½Å Ôàµh‚P½™¢‰?Ï'[Ñæⶠo˜}Ü7GåÅQ•—ÞˆÏ ·òe›Ë¥¿UåÀTSña‡úÂÅ×Ð8ø5ü«üå„X`ÚÇ°ëk4”Ã`$Öí最Z¶¯ÚÒHl{¢W açYš/Ëí.Ïþœè3,æ-Î;jwÔÐQþÛ‹ «Îp`°häÂH˜KâØ8Óœ)Û  MŒdB Øh˜¯Ò*muغq í:„Ž àwÜÝÁç4H$œ©¼Y‡œïŒIA!Ñ)(||a¼UPÄ{A¿.NxDøVq»N?L®“åšÖÉ[ÿŸ}G}^ÒÌj5ëUú†h[LÁ,U©FþÚ-D0!rÂâÎ6üªß,a²ósßMŒe˜ŒÅÔXC:½ŒúcùI_­î|ãË£€LnFfýßÆMë;šÄO_Ÿˆ©h ó ª$`Q# -O,cèŽKªóib8@u$`²³)ÂÉ^5Éd'6ؾ|¢+à·¨ÝzAÚκƒ ^uv/Ä$Ô™vv•²b…¸Ç €–šf¸ç9±Í°ò0äÀ›'ƒ}Fs|É&–B׃vj„dÜ*~ÈÌÝX»÷ÌÜÀé¢3ìÓÆwöE}½ÝfMµYRÆ2­}Q82Òœ!ÛF³ ±>Nä3(‘LtVÐéÞ4bÈ7àMÚ6Úð‚Æäî¹SõtÌ8.?Xš¯­zæ!jþoU ?¶²¯z‘0X@Å"«ï©™:´[g`Öýåƒ)‰É R7­–Ú´"#@Vì*¹Ó‘“g€x#.æžîP;%¿é¢RÓ|d: ©HÛ;¨H™RÑaÈu¶Î-Ë ÀPB¶¾Ÿ'6\³`ñ¿Úñiëb$ÑCw\=iÇÁXèœlGÁ°åDÁ:ž÷ ò=Cêp¶Šuòûøø³²ç%#`‘Ûl\‰+œ¼"¿%y‰ÆñU¸J€¸ÏSÿ þÓ(bOf1ó涬 ªŸBˆÖÚæv~µiÖnùx ~ F1·3½áƒln(omnÈ\–ù~[]mêÌ9ÝfÜu Uª*«we±r‘jlåBð[ýY¨<ôg'BV$…Á»Å²7\îÀ‹€ïñàå‡6«ý.ß,Ó&ë·ì}M‰óà”F³":¥# .¨ë Ó.-ü¼¼iZ…¬öËf߆fB¬&_€Æ_áŸô:T ]³`thcÛp‹[ÚÌ1œPt„ßžñµ×?±¦s°ïºû Ò™®¤‹Îc«¬^V›s?NÜ¥M“U}¸°ÔmKÛîwïC:´œ5~ÍGϯ1‡[x¾¯Ý¥¤Î³‹²ÊFÅPñË“ªp\ÆêäÃýB®"â64O²{SR:7³b¹FæóŸW.P‚©èïL„}ÂælSß —w ªÒ|óW¨PVô»ÚÀ°9_@Wû&[ù©RΈþH×õÆßz’µ‚¿W°&ÙHäîÉ + *¼÷i³& ¹)ÜbÊð è²®Öe¨W¤ÛТ¦ÂË v¤ÙEèl4ìè»ÿýç“·g¯'Œ$Ç ME†qû$#‰#µÓa Ž8Å N¬ëïÞ½~BhFòœQQ°Þ‚‚¦šÃuݦÕï¨{Yƒ]´j„À}zö‚ Ú]!õÂGú.ÍŠX ^Î Úä…}¢ßAŽàEKðätŽG¬]ÔçX!=aA¢%VAwÁ˜7"F$Ei½Šå»ªDOÅñ(vA¯7 µ)à”pTK¶£ŒžŽ@Îm„çe’È>4Ã÷‰O …:D=¡¯3&Fr¼ÆYyv±,#véMUÃ1xµÉsJÑšæîXÀ Ñ—s/°B½v®(&Ñ(÷m(Ý5((/¥ŸÀõn4âzL×»ú¾ÿU†U äüDÄÆ ´ODwð½°hYÅ3°í˜O"p¯cC=á+³)¾Gï1™§»]V¬Ü<´¥yhÿÞUZüN)·Œ]‘lŽNh%ûMÁÛî („*hëÃfÑ`‰\4~À‰ÆQ¡žÒ’(s xÞGv¤‘z–¹•6ø` ôOAŸ² o4õ¼rc<ë…÷J΢[æû•—ô¼lÖ#¢gsÝÝ' ËZ3%"¼úÕ0p†ÅÖ¯†?øßì+hVmI]´;å‚Þ¥¤ô³Ê }0ƪÍåº9Z»ñ°¨Þ¬2Jü딎ݳì¢ýâú;ÝŸ×Ù’¼1lŒo‘Ùð† AåNáàІ†Õ— ar¨ÜÄ Ð×f qÞ’nÝdeÂCÒ¨ï&+oÿ!ÓF1™Ÿ‡¼â‹Ó¼.)…ÆDãÜRåàa1ý„À"Œ” F4s„¾ãü(Ú½bºzí™0êÒ5™"XþÛ%NÀp”3àrçÈ?…PÀE‰©'îpú„Òžëþàò0mÙ¥®#²j]“ÕÌл$Bˆ Dx“à+YpˆDpˆ‚;ô‰^ìÜ#!àÚo)X¼\ï›àî÷ÌÀ¿2ª~tA­½ª¬6éeY¸€X_­êeš{¿Åm’ýÈ“±£MLCAJŸ0>Žùê½q‘`6©3äxjßGå³—%¸SeîÜ-, 'bØ7ÀEª3ß¾úpöd&.C‡zÄ@ÙB;‡t@( vOÇ7†µ÷«À|°Ý ÙVøvº}qëÁˆQm$–ÎËÝëA6a?sgۙܶ 7'¯t{O1ƽ{¤ŒtÊ?ƒíÇ ç§¶™ÏXût«ç½Ê¾³Vð³ÃŠ«S¬Žñé±(ny¼´ƒÕé<´¦½Ÿã7f€PJ1 ¶~röÄi,ú÷•^{aõ)ËÞqöPõÊöºgµ¯Ú¨Gý±Ï ´o§lþGúp Êî®­…€¼’–i12ú²”`âJéÑKžO S©ÅüK¸s9N« LpíŒUàÛ/eþ%[M½ªVÑ`8œ/;Ädšç2h^ÜýSÄN'"‚ŠC s§¥‡y˜ýÁ”ÂÀ7ô„AåÕòÓë“;ooQ·ÏinñÓ•5LIñ8QGÿ™¸ Ù@TôÓ_>? ‹“ÖE~õñÝé«—wMN^­ÅS¸»h?ùøóx´ûÐ «çþýç.ôâ…Ý5N<礣¼gì¡ÑÂa?@Mp£;m£¿dnlVïù ŒøDÀ¦Š^`ÉÕW?Æ·­xç¯qj’Yá_Éœ¶-Éõû,¤~ •íƒñvfë¦Ù}{| „»f¸òì²ürüÞÑïû´ú=kŽïYv¬ £‡÷èNÇ^4iÇ‹÷_ÿ– endstream endobj 1379 0 obj << /Length 3840 /Filter /FlateDecode >> stream xÚÕ[Ksã6¾Ï¯Ðe«ä* !ÞD¶rH²I*©Ì#3“Mmes %ÚfE"µ"5ç×o7 AJ²-'•ìžˆ—€Fw£ûë”ÍnfÙì›ÙäûÅûŸ|-Ý,gÎ5{=ãš3“‰™É5ã’ÏÞ¯f?ϳ‹…ÐÙüÓ‹_Þ×ÿvöóBk3ÕPç²Yï75•·ån³ïŠî‚Ï«&´Um·Ùî»rÅÆ“e³ÌiA+òV|[^,¤3a™r…5;ßÝ®úHåÛ¢¥!ôÅÎú‚ëù=Õʆ–¡ Ä¡UVUqÓÔÅšjq†mÓ¶ÕÕºd ”"ìüÃ…Ðób½/Ê4w0ˆŸqŸs°» vçhwà ¸ÉbWR¡¹Ž WU·+v÷Tm«ßÊ ·ý¬È³ %ñ(ÏŒëEãå‚ (ü¶ûå-”l6G±Ý‚ð¨ØnŠõºl;ªõ»¦ªŸ,ð»¯éKÝ6K%ͽ䈜S\Û« ðT††= “Ïëý¦ÜUKÏÏ”¶–êž­0¬£ñа«n*b?4Óê—P±jþïLg›ýfë©xñÕûÿyÁÙŒÏT&˜Òff¤e:s³åæÅÏ¿d³t~7˘tùìÎÝÌ3 ëÙ»?9c*ƒ³¥h¦xĶÅîoŸÃêü’hÜì‘ÕHßU z»kP…?T+àòh!¤cRé1—®‚ÖÐn¡°oË•Vû]UßLº `Ä}OçNΓ”M> lÿ¼àœƒWEê’à áÛ xPô¹«º[´ª®Qr×å®ô¿ã^O®›Þ%ž;å⹃щÐqäèò¬_±‹ã¡csP¹Sªö€p§™•3°‘ ¤ù|%à.gJøy”š*17è”®‚°F:@=¼¸•a9ÏÇöX=f[0µÝo Ä-"ó±<¨õæWAƶA ‚òåªmƒ!.! 5K<§ýõüIlƒNV‡ò:!Œb–Û™¶9êÆó•BËTFiù?¥œk–gz¬úQ—£5’·Ú/;ªøs ½]ìM<4žùØØÄm@óüTôP­Â¯Rí0ÂÎß>øcçdT¹ìšÝi?ãý±ÖmC¥ZB{ -Ì«:0!c LÏvÈXyû ˆZeéù܈1~Ñ/_ÿîËÏG|œè†4,s6ŽGÎ[Ï0kúåÞ¾þé±åÖÅñ—a“×ôýöËWï¿Ç‘“^ú¾60¥ì¨Ðæ-~Aœ;ª[Ë‚ÿ®•¹ÿÓ…‚“î}‚V(ú6¿ä¨R9i2çQIÔ¼nêßJ8Ú¥ÆÚUÕý‡Ú¥P=^#°±©C¤íQkª9W- à΃œ|„‘¬#­ÁvÀQTp(GEGÇ·H¨… Ô€^müUQÓd(¶”ÿÙqÊ&tÕaj¿K\4!-B$8?@;¶“¯‘¿~~@ ûº½ßlJ fI ž7ËXž fœ9ÉÏPy8"ƒ>Gå…rg¨<,—÷«y™ãfË¢½»Þ¯©sÀºùÌæ ²øäk­’Ù<¸&'Žçó‹…¶|þCøžiæ¬5Þp8ðf¶€Ñpîýè% Qm˜‘ ÂsÙ–å#¼+-¤™ºÓU  >Nƒüµö§zlÓ±ƒ#òÎô øƒD7„ÔÏÖ 3Ãź¡À±òçë†f™>G7ÆËù 6ô›š:X7ãXñÂè\‘ÇÍmŠ3rsZi`gU\öó#âÏY6xÉ"€d\%Dù8VÅe=öÊíÃT]È:A ¨e¦³ŒeBÿž¨HuÐv¦ðM˜û\qøaWe`±5ŒOYüç ¡4$ `È<†Þ$Y賌cÆ=áçêD¶ï¨Bá– <‰Š|ÏúÕÝn0a‰;qc57ÖQÜøíh| v±9Šûdü}* ÌBªŒöÂø=!‘fJâL VjÀ_I–K9ŽíÂþæ@j eƒàxÄ܃ȸ,¼ßQöÁFëyO5JU$ëz»ï¨ØÇ"PöXÂÿ`t…o ³¡ºmÚ*å<µ®€þLÔUêÈŽ3±ULô¾û×ˉòéÑ`Ǹêvd¿ \ÜöêÉCCr@ÈjIÔr^Ì+Põ©½.¨*à?)óÃ4Ü™‡Œ¹¼GC½¦ëÇNXøLöÐÿ³¸¡)È:šM(€CÂLøšj©û°óøÝAHV¶ds ú ê)•ìDän~ȇ­ˆxÈíáNšÝªŒq ýHžY –»Ã4³”17#mp³2Dçí3Žîp³öIbsb“:ªg#}€À–·ûÐÖg¡ŸE,€áô±Ü¡vt’ |RÒàfÞûð—?¾|ó¬pOOžg†ÁŠ7ß½þâ¡ÝsÃxâj1RÀôÆ´a›Ë¥¿€òJÒ„öèR&ù$Í0VÄ>Ue†üÓmÓ†Ô¬‡ÓûÅØ3.0`ºwû«qÍ$;yw¸OÝUtž,ȉJNy·6äÈü©Á¼·¬Šøpí¨á:õ îà ½µ'^±„lÅô¢B1®‡{ß 6YrQ¤Xºµä侪þ¾õöSÌ74^äéÅ’`ʉ)¶™L !ŸíU©:6 C ‡Iø±T3€*RÂ"GúÔÌøI\Ì'™›áQHÿ,ƒ‡ ÌFÇÇÉÚ×5å#n.üë“2@Cl´)tÄ1ÐÓÄŒ¦T,¾m<ŽE&X6Üýß`G3¸þ °ãhÝdzQRª‡bhyôI&IDì¨4aÇôaÇØ-ÂW†¯ _¾&| )øÇ!;š v ¯"ü7z>Çà›ögÂK ü®0„ÜTu˜¸ abZwbzvå²í¬Cºfšt€sÜË&Q-FžnÐÕL™Ä²ì`’É´qjr;•œíìLj”äO ÄM&9MÉ6$OX|Ý+¤ì TăàÚ`eš€î^dÀÄ8 !÷TÂÔ9á“a–›§„Û‡W:ë÷ûè$é/Ç>6`¦s!™MoV¯éÁ Îaqë]Q­Ûà_Íç?]4(iav*—ÝÔà¯è•Šœ¯ËîXÒ65€§À’ÌضåºôO̬ŒÏj"opØhËoî© ™: Žh*¸Žü±Œ7¾#l9`þf²Á¶ émÉ9ÓF?xsH‰tL?œ1t>­— ¯ñœ#û–Eç !˜‚¦_ëOÄ]K„>Fcû°' pڼܱàyù±Øl×%À—HØQìo0±ïí4·÷mWn¨ ÷ww[ùÇåÉœñE=Ÿ¦–û_CTM×á‚ulÀKtžCI­ÑaG 0_7Ë_û+!è‚ö>è‚r¸å“q÷Â¥aWÚü¼øŽP&̃p—[5ã6gpG¤àÐhC3eR<1’LÛžB¿mØ-b^RZIiqÚb „ŒÔ†/‡¨œ/`L“éS)ËCä’xõ˜i§Âñ ¯¤gû)‰\ Lq4h†9^J½Á¸ú‚ÃM¨ôöQ¹Ñž£»ÅølÑŒMž˜‘BÙðº€:üCG]öó–ÔÒâ R¹ø3µNÑ#³ß}qÄC8h3º8¢yc昱|¬¿ÄÂ_‚Ò×GP½öWËøf³ú- Š¶QgÞ#¿AGþ”/“wUµö“bGþ¾¿ÖÀW¥šõ‡’Æö°@zþ ×&kÏ ÄðàÈ«µG³ñ¢ãÌ<ÎIÿŒâH@ÌÜc$ût0Tr’’Y°D`F˜²‡»ÑOÀþîWw– endstream endobj 1250 0 obj << /Type /ObjStm /N 100 /First 996 /Length 2802 /Filter /FlateDecode >> stream xÚ½[Ûr·}çWàÑzÁݸ¦X®¢hË–K·"é$Ž¬ZÞH*Ë\…\¥”¿Ï9ØÅ’”¸³FS–µ˜Lã ÐÝ8Ýhù¢Æ™”’ Éx ÑTÁoqF¢C#zKdCLöʆšØ'SsaϽãë‘i<@+¯)ðº„êÙªÆ'a—Ñ9QZƒê8R#N3[jÄçö4QWÙŠà8, BfÆ)ÉÒú#%rŒTÔÌ7²3ê=GËÞ(a£%Fµr4ˆ×è[¿`”ß‘£Ñ\ˆ¹ _‡10=Z Rð 8G|˜àš¼‚is•RJ6Ácö|k´!J1A”JE«<•6îiÖ¯âVP .·ÏRßÀ G§€9Œž3'X¢ˆ¯dKM Âõ©ÁÄØ€ÖhbZ>MX<Åìknï“|û àN0šbþ“bÉÑò&EN¸bð”‚gKMj¨¯¥†J¤Ôå»RK=ð€—FÞ h5q ¥¡ yõ¸ñZÑäDR,Nι=Í&ΣúbŠã)f¤ø¦FâLÁTcªÄC÷¨…Še/‘ªLIÔC¬±)E8”¬ÔÔžfS]%*­¢Wª©M7U©³„{bj’‚1”j]*<-í ïÑjcxô«m À¨mJ)Ý9jšjkB“=?ÆyLS¦çc}œ8ÇQ<›T¥\„_ Εv—Sïjæ÷s²``­¾VJtñ2'ƒ/øèÛ] á—Óð®Ç ߙ—x/ÁÖOÌðÏ_þEœ–½Õ%›¡þß¿uðí·zçbs¡@±su«÷£ùÅšá‘B©£½öó¡ôË |Yðë ¡±¬.03k³ºÀ;¹ ÀbcVG-Öq ÙB á‹­·j“÷wÂ8ýåéˆ ‘«¥öGÉ6Á)@±OFÅuÕ»çáäÙˆjµøÚ5€à9°ß à§ã 6Ë A,6Š­ŽFT ãàâC¨;<è‰udP—Ë6=Œ£ê¡VaˆA¡ðGpi¶8Â*0̺ ‡/cÑmc…0 ÿ|´©q¾bÅÅ ˆÚ ¢£%Zð=PRÌèfÉƦÖn9~rV@Š< †T:ãºè„8b±ØA®,I¡`A* ˆ;¥†@×@‚znÚ äÃùåù›Ëóo-´ ÿù-[W7XI»õØȹ£L¹:PSæ-Þy‰6pcStiÂÕ©ÎFò^l¬0cšm‰ñØWs¾Û¼8:Ñ»hÿ ÂÅ/Ì¡6xóm‘¯?¾ Ëñ"¨g’`5ˆèPÓ”f‚€BꯀhÄ ¤:=-­0¡àá?`¾À0Z˜†Ègƒ½þøïù|áfVG´TñV¸$;;ȦhµËð ×I¦ÐMè"¿| PeÊc*]9IòùvÝdìétJÝ„Wð¹ãP’&þ:Ž!w!×ÚÂéŒûËPúfÇJ'8N¯»zkñ¶åXÀèÝ÷”= Ô]²YZædöë½– ÇŽpsGçUv!dlR’öí…TvÁÎÙ®9{ôöž»³šŠÍ;–½·Ó7·²·rÊ‹õ;b¨e_ä7€Ký"YÁ,Û½“¹g rÏäž%¨='P{N öœ@í9Ú³ µË©]N]ËYe˜\\5|oHo訹q¶R¡s$¬t³ŒpLha7¹ ðrp³‰!ØØVãºÙ?ÅI ì‰Yá &0YPv•ðõ0ªWP䤱 ¤Z¦Žß"º›’ F|9|D")Ž-fÿh¾ qÌ×W…¾áÅê-3ã}ÇKª0a Çp:ÂÚ·X¦»à +m̸¬uÚX2¶³Š¶,Œ%kð&r™Ê”äÔCTÖ@ÜÆ Ó!;ŽpNA¤ƒ…ˆÃÊ0 0"즡ìa[ÏÍg0ûë•ñLš,äÁɤð-qH 7Õ}pŒl2äeí¨C¡"÷¡2<†A<·ICž}ÿälL¶Îíï05&íTp3xq6¢#Çx6pÕó„“PÜòüÇoHSÃßÇÜLÄUÌC1t¡ðáÌs¸ÐŽÕ¬ÈÝ qôýûÅç,ç«{±ô[w²ô»{3›/º«w'Ç°ýÿ:%½ÍBoòÓÛ,ôæÁÚ#³m§l×ÄõÞ\UõK®ªþÞ\UWŸÝŽWÔ¹7JotÖ)uJg¢½ÑJ(] tÒJ¨k2&imç ÍX)KbÌsîGöW'8‡ d‰•0lϪ<« °-è·;*c‹5 !8ŒQ‚åwàù˜›â@Žù:D6\¢O'®ÃT‘}(´ï„É_{JÌsO0Ð5ÆM€$Yž M€ä°²¤Ü” ÔÒ¨áàwŠ¨àèØè1àK°©Õñ:îȆm1eë±pLm§ %6*ÆŸ¦8/6–W©¥K ÌäbEÁƒ¦|'€«¿ñÞ7¿°Ü+Ç<ãЪ-|³ôɤB‰4„ ¼œ';-`ëziD‹êvÂ7z)®mØçliÔ”åPªßŠCF£@E9tܵ"l·•îáçîDÇÏW/f—Ž¸&>Ûâ¯1„ÂÉVÇÏŸœk±š®1Dì^Iu+†“çÿ؆á®AÁ·"6ÊÀƒ7ºkðã\¼©> stream xÚ½ÛnÛÆò=_¡—2`m¸7^Rô¡M›"E÷Ä)Šƒ´´DÙD%Q%©¸îן¹ì’KŠV"§8OÜ]îefvî³ÑìvÍ~|¾ß½öü•Îf©ÈâØÌÞ¯gÒF"µé,N­ZÎÞ¯fæ õââ÷?uËfÖÆóëe¾)w· ¨ù²Úîm±âÞêPwò]¾yhÊ{zþ{d£æB΋‚ûÜÎv®q{l¼Ã3æÊŽN_>:™NRñxÁ ºªù´ö®à‘îyØn‹¶.—þ¼)<¼«Oƒ–œ>IÑI0e&ÈŒž-d$2›1=ƒ£MÑÑ@).`–Vó÷¤Éäü@„ª¹s—7Üha°âæ¾®.¤,WnEËK£ùî°-à€|Ãã/”ç°ps(Ü6Õz´¤ªËÛrçWlar0þMXDCð·‡í¾!*üðþÙ_Ï6H!™Y‘èYka¤š-·Ï>üÍVðv:Kg÷4s;S"Π±™]?ûÏ'f©0Š6RRó¹û¼ÆŸ¿²Q8S ca'šòOl•ˆ8õÿ¿EJ_,”„wü-vmýÀͶr_$ 6<óŠá}/â W@Tñb"?!&‘ olÅ#7üeÖ„Æ¡+·vì`€ ËóºÎnoMë¶(Û¼Ü9ˆ"$,ó±ï/?eBR* b¯bO¬—W?_¿üv€Ôˆ´ÚŠ(êæ£èœuž´"NŒ_þîê·³Ž«»ÙB++R`¦ú[Íߪgu¤»ë 7½lAþÉÛ’ø†÷w¤påßÉï@—d"ÐH@g5¿¿«xÕœ;ÊíR;Ú5åÍÆ-%|³©–9Š3Þ‘&RVÏ×uQ(KŒ²ÞÐ*š¿^óÇ®6%ÌÍ-K/-!¨`,P<ØE1>ó¾Ð,˜Ì_Àõßœº-ƒ é&ÇJ‰ˆ]…òxÙa¶ ä„a¿«Gb×jÖ¯ I¡ÒtH¹ö.oÇ’Œ¢s¶&Ö¤gp§VùéLsÐ.ˆÏí‚tgü£ù¾*wmóˆöiò­k§”^cåM¯Å¾A™Å"QÙ⮄Jºùc¥¨U¿­ÓŠŠ'E ݤj|ën¼Ž#<öûMY€T¬ž{§btP4Ô»òÄ ß—ùmµó@çÀÎþ¨ÞiÁžwZT Ut§TÞ"ªŠË“PêP¾¬6‡ín‚K´õÿÝ]™0¾«Ð‡¸‡*sšI#7"¯CàaÒ œç¦ 0Tî~"µ+Û‚ÇkÞ.ÚæìªzÛ FÐ&¼ øÓ!¯=ò8½CÞ¹[2Y‚3è±èÖ7—œ Êu¹=lÚ|WT2Ë™G :x*ù’0êÄAÀ¾8pÚG´×Oéh‡sí°‰ðâÿî¨QSîhxþ‰Å2ydqàÒG=ññOàÜQû f§ˆïX2=Mür“£Ã[Rž:Žñ¶°{söm!Žm«ºàø¸UÍw“˜<0\à=ü½»2¼–`_G¯Á+S:¤ üëhmöã`á ÆL?͘G´IÁ‰UCÚ$§8óÛC[@¶ÞÞUåÒé‹j=R @l0üÿúåÛ÷?£±J{s³ªvű*šv“{#‡V'‘UtÛ™1ŒÉ÷Å:9rÐ$Çn¼I…¥7>/˜= Ì<@•g€röÍÃù}¾ü3¿¥ìs _80ð¿+6y§£1JþÛ ‚ŽWÜLÅ$‘P6@æ,»mÁÌvŽFwKñ cjéΟ¹<Ó&5GgJõ(Ý£ŸT†±cnóúÏ)Bi) nÝ:ÇW“Oqè7üIôÍSïŠk‹âΫ>ÁaÏ'Ø®Öüe)†F¯•aaµg)ÅÛü7n澨Áµß«K•0àऄÑó3¦—ã‚?lôÉìUõà· 5˜]V D)g pN±Fi^Ë¡‰Á}B97ä\¯¸µö'Ô¸è¾uÑê_rnh9Šm^¿}uõ#¤õ'Ù6F¦½ÓI…>*ñ~@ºI'sÛ͉¤'¸‰'?¹ŠR-“¸I@ʇѮu‘¯Üùïð½q¿ˆ¾Ä …(ð7NacÂhys°°is[øUá`Ë!Þðì%19 ߸‰Ìèv-Kˆ‰7îÔÀ€™^—ãA¾þÜ#þalêlW qMÑt:ÒzEq¦Ó Ç’'è1Щü’¤ƒL³ÏQe'‘Svt½2VBÆ£À‡u”¿_h¸à\[Ùç4Üð7LH:Šž‰—­ã§çx¨ä%1LœëÄvjRb"l‘>tðÿ®T¬hrLm¿0r_ßOÜœ”—±fÙ’Ó€ì¥<)œ s"› ;Øžó\’€qª5„K¹ýØ⃨v ›»¿‘è¸;pùI»Ÿ12²K¬€Dt‰nüoþ›b BFÎ/tÑänÙîÓF"±öˆQígȇÌÒ0ï°HŸh1Ê'Z`”ï’ZÍ C÷ÇM¦/ ¹~íHÞßWf‚z2‡õ/]O Zƒt\ !eÉé< k›b{³¡­à_w_]zNÍWeƒ.FðŸpC1xõ}>²W%éyªäy©.µË ž«ÎŒ2IŸÄ%±dçàôÈK|¤ƒ&q gÛ²Lhò~[0¸Ïä’¿éH<½£ÞÝwÀ?—‹Ü—OkLe‡|Z³Dœ‚¨Yˆ©˜jqØÞû¼F¸E§Ç£Ÿˆý  L†9=%ÂG«ì³tŠ ÃÄš΄ÆoB¢S¤&N˜ñáP4#CL(þØßU-ðuãŒP¼l‰…@'ZÍ_!·Ñ½dñDöà¾óĄ́Ñ~£ž+3Çkî<©"æ.…TÀ\Ë2§ºèB+=M Ç©DküÃŽ¥0S'Q¤‡ ˇ)ŸƒíN½¿ùõÍ/×ÓbÖG-ε¼;iøˆ|‰"àªúu5ý€»ÈñûJ·¾9,ï|j$Û·H©œúÈ:®þzO÷ÏWi0_¡øªPÁLlªDÚGbåÔ.<íèCX4k†ï•ºÊÅ09ªê0}DÍ `2^Êbg.).]‡ñ×#!½‡úTÄóX¯ª§2ItœüHOÅPÙ˜´ňaP%c8†ÞçAÕ'Ì­õ“O~¹½ÅâÄžapû'ã2Iq¹êk; +õcˆ(“¡÷òåx( ÔÐxw¡£ùÕðÓoÓèl”=·Áž <¥Neq˜ÎÕÖ£§„B÷õ²NãZ©\¡É•d¡€ÿœÀÓ ¦(§:òÍ¥OyE”4¨§Î’*§Ù°Ñ? €N_TÂ)mbz-6¬Ül¼›¢%‹[Ö…ÛÓ%b¡uã¾lV îÖ tækô—jÔ"SÓîÛÅ•GÃ):£ õZwÓ¸”J9V\X|ØpÍÝûÄäÄ7TΚôŠ1ÿÇ–´©é“*I99û‚«î”Ä„~ªÎkø;|'‰Ó¨( \¤‘ú˜ ~=%+˜ 3Q`˜JR œÒŠ§—Lô^¥h}N7%óJ‰³$¨~až‡^‰ŽµÞ;pïç2ñhÒÖåUÙ¯œ¬žûzæ yÐeönŠuÕåý‹4ùìíÔ»ˆ¡:ãekQöÌQ匿ïÎ(Ž¨®Ö3Á˜(gS;, \9˜ÙÃq|Vo¹¤µ`~Œ“Èe¸u4XêûŽ`Î endstream endobj 1453 0 obj << /Length 3286 /Filter /FlateDecode >> stream xÚÅZKsÛ8¾çWèHUY0|¦*‡ìd2›ÙMâM<µµ•™%Q6w(ÒCRI<¿~»Ñ ¾$Ë–í©=Ø!èntýåìj&g?½w´»|qþÖ$³X$aèÏ.73IÅzÆPFÍ.׳/Þ»Íü·ËŸá-)ü³_wŸ~‚E|9\DŠ8Š` ½ýÇËþ*Â?Å+Ñþ“Í}#$ ð{¯‚ùBÒ«jjóù"ÔÊKËõiäJ„¾Ú#'~9qGÎBé‰"&¨½Îæ*ðnç‹À¼´Î¸³k«mÚæ«´(ÜoEQ­Ò6[ó#q2[(‰ÐJ‘ í·ª¶7;;7[ÞR‹{ÙÎMºú=½â‡õ®ÎË«ÉŒ´L‹Û&oxþuÚdbÄ®ka_ûÐj'íÿª¿åM\ñˆKå3—ð<å‡\âÔrMã=G8¼äÙ–^ìtᯎ#7ÅÔQ9Òf®€ÓU[ÕùŸ@EUN¹]Ðü¦ÆC]‘ðcµŽ„TÌk ü9,+¥wQÏUìe7¶©VYÓ/ç Û4·ÛmÖÖùŠ÷Èêí®µ›6´ÓH{$Š[° ]ÚcñCou]å+Û¼jCctf00ÜÆ[Ð?4³t¾3³‹4DuÎF{…^SÑžxrVÍ`¬ª× žçnêj{­Í¾Ø™?þ±sâ‡%Ѽ‚=óâ©V#¡Ý¦så•pâ¼·Uq&¬JS³(Ûº*œÔ)È+«›Ó!L„Ö{€ ïG„Š{ž´©zgö6îÝ3ºÛòdìSãq²Ïjr߶ [aèÞ[g¿J©ËŒ²¢šëÀûö²³°þÅ…6Fh<5À4 ü.OÙŒDÜ+óu›—£×·ë ሚ&ûc—•mžc\N{ÝÅ.aŠY½©êm¶> ŒçoC9â,xL,g±ãì‘æ? GuÇÍ’®QîÄôëªi™°ÚbÏs ûDØBù"6ÃŽäX·,xù¯i±ËÁؤ UÏ×ÈÀ 5&ŽyñæÈ—S‚üºÚ’€qÌ„EÑSR×bM€Õ¬2ø¾f_c!IÌqxïJú¥½F¡Ù9xrÐ#ßf‡þÑ@Ëuµ¦)î¥&k©§w’%ꯓG@(’$"ó‘FÀÂHX)Rc<},$tÐ;¶¨m–– ¿¢S^\ºsyh¥›½@fh§ýØIUU U¥€¨K„#ÕÐUƒVÍ°$j¢¾‘ÞkúgÂ<&¤$’䎽‰ –UaUžE# éþ\£ž6Ó%’5ˆ‚“h|*$(ôv H8< ÕÀ+o1³@¡£L[tÔ±ñªÒÎH¼‘óò00 7 ‡<á$oCÓð˜Üº0ߪ‚ýa»³˜ÃK^1kÀÄÿ4/R@ ¦$4ÜâBh·|Ê1‹Íuµ+ ˪už¥;xù-P#=ß•Nuœ¶­{Oð‡F <Õ ÐvÁ1Kóä^_—9[ ï Ñ-y¹¼(&r¨³´ËRž&ôrLÛl“îŠv€î‡œp,‚!¸[±ËÞ»`ˆØ{’»Ëóðê#çð®Dƒ„%—y‘··‡Ž/¢dèH#Q4íûñ@½ñ©wŠ¾Ÿ0dǤ]öç©æÒ<.JšÐºe?¯®w5ýŠôÙý‹ýi'²«y^Þб3‘#Z{[ù¦«&‡頻JN S_©3M$X‡ÖàhµIÌÌãhJÍ6ýžow[zhë´l¾¢öBŒm­˜äŠ?N¬x2èä% ­[´u0ÎX?Ë ùÊE&N ©!–‘~øäBÊ"—ªmk<ÃÏ>·vì[ñaKˆŒS!!‚s]枆z#åù»2…ˆp»´)X7y•±b…¾±Kâ^X'ÊI$ñ¾˜‚ Š\ñ"Åÿ71¬f:ån»DdÃ>º!ô­Ç"Àáð!„áMů ¬g÷Öl(ÂÀQPº”'´µêŒ„‘’Ô“2 .müˆOÈ8#Ç¡¼Ì){ÀwF†¬ÚŽÙ‚ÇwÀàm†µ üÉú#P )4;4ÈCŒ­ê8²í& ¯Y®3æ3ßvŒrýWÛŠÂ$3ÛfÛª¾‡6øuè}¨ZD® d[3­–n,£!ÄG ¥ì(1Ïã.Àáuv“•ë†*'s¢ã -:D¯ê†Æ!A¡êɃ.]àV±1†Úá*ø¼¡Ðd”®Ä#M°AÄ-u–¼²c·4Èd€ìïyï/ÞH`G;!þ€£Ò¡d2¡óþ—÷ŸÏ¨o4äÔ•ºè˜°m °m6·nàWiƒ(xZUeÑ 6üú†ÚÂQ>R>Ü`6äKï£Ûv×B qö4q ¦á¸*†‰¯%WE´d—,]TÛîÙ˜@+Wø„»=¨YSëDÁñ–vN{ßlªÍ‹d<ªM¶jóÞ•¢ËÆ!Ki²’ãt¢~N¹s)ØÖ•4±f>Jká»zþŸØw~¾óå‡u Õ(C¬@‚Ü_*Œ+þv&%椌9h¢µ]”Þæ¢JàÝ°P˜- 9õìÞ挞m˜z¤àAç²`.réBG™=àÂ&Þ->ð»øñÓ{ûú—/þx±¤œ©™NðbÂÌ´€‘ÕöÅ—ßäl ?‚×&‰gßìÔí :Åìó‹ÑÕú8—@„¤•BßÕ?>>]>G¬÷ù?X3àL? k&JMXëäùà 2Ž ¨ÔÕÕð0©Ëqeë`áøõ ßsH yÛ÷."XÛÒ<¿±ÙáU lòõû7£¥÷…—EŠìYaÇ O¡î·q~…€|vü"äé6ò2FM½±À®+ÀbÉoX?nn©mÝZ¶m{yybàAßOŽ›™Áã‘ÉLÅl2~Š.`Õ ­$£ä¡f r*’T9‘¹+W½re>Œ-NÓô”ga|¢Í.´ÄÿðCÊËþ~ïù‚ô‘Dƒa@r;7"–¬FÁÑÀÀ¬q0ýH@`’;"‚Ñg~Cþyd㾡r^í—™äeÓºO»¥5Œ´îJ?õ;réMO>ðÁ«OÞ?"ö‹ŸÞœ&pCP9xøl÷ÍB°ÿ³ŒÇîÐ¯Í =„,â(pà7¼Òæ ìIV)˜Î’bâ` Ìv T;à @Áˆ¶%]~O„ý>s½@õ/+c e´¹nÛ›—ççW›ª¾ÊD^‚÷›úÀà¿ÙªmΛUÕ®®Ï÷x° 8\¿¿ v˜]-ÛÔûµªnÐ :#þ!Î €5ÐÞP$*(×½x“7€ƒKôˆý×¹ßòö:gÇ6’D$2ì"[5<°‹ÊúÒ´S",åø¸ ‰ûrægA-ÞQ²_ÊAõ«nl xøâ…M¬Ò—U]Ká¸ÌJ“®ÈHЕ…¤¹¼bÔTSÿŽa& endstream endobj 1382 0 obj << /Type /ObjStm /N 100 /First 1011 /Length 2943 /Filter /FlateDecode >> stream xÚ½[Ûn7}×WðÑyá°ŠÅ›`p8ñ"‰ ËÁn6ñƒ"OmW Ù¯ßs8CÉÒJ£ÁªÕ€%³Õìâi²X—Ãj‰V]p­9QüÄœfcCœaC]Š‰èraçd®†þ—äšõ>ÙI(…-üR‰{hÕµ8ü‚`+”žq™…ý2+‰B²:©•st$³eN%õ'’Sm½_vjQÙ*NSŒ‘+жþlsZ#¢¶Ù%ô¿©‹Ú‘âFä ‰58ÀWbFÃ(oØg‚Jáks&Ö…$gƒ­ìÌ´ ‰ÎRÓŠ~¹ñu+úÕõ]ôk} jq)TŽñI…òjãÄr <–¬ñ üJY9A Ó^2GkÑ¥Ú8Í\}-0#˜GÊkÙe]ß-.[ìOT—S&*ÜÀša Áå¹xçÜð h©+•´]éd˜¯Kï—\IÒûeW2ô­âJé3ª+MsÕÕA÷4°Ñ W18–³¢Qù¶-œ ü½j_ÄÕ¨” áÕjwk_‚kAˆNªk’°à&Í5íã+îZSÝR×1ˆj™Êb]«‘òÐ¥µÜŸÀÐõÁ”úº~_NvˆŽ¢WH0÷BȆ{FÌ¡pÝCEEDg>Æ)i½„ã›M¬ É}`LŒH‰½‰[RsÂh\ ,ôýħš9µS¹¬h¢—&íM ûý1ôÒ8•­­¯tWÛ¾/-±©–÷ž>Ý[¼ýëãÒ-žœ¬Î÷?Ÿ÷ëoŽO~ß[|±:}¿<ý1À,„w‹¯/Ï”~±·x³<:w?b#x²Åª>bi  >b ²J~ÏÜÓ§nqà_­Þ®ÜâK÷äà‡o?sŸ¾‡ Ö<ôÛØwÛÒ x°×«x¨å­ã¿|þÝÛo~z’~úl:Ñ‚Ïv…›×‡TvÁ¡uJ Ð=hØrð0œ±zj9 ¡7kÛ`”I§#òµË'¡R9îG!mJš¢O0{piž[(ó°xX ŒI×DU<=SŒæ¬?ö©/Ü$†ë¼U9¦Å‘›WX¬#Jó°;ÀT;26)üH6 vÞÑÂ-ãZm¶M oáa¢¯p`ó&øˆpL« V¡§TÌ ´±0q+ZQ¸–O5#6ßàr×ÛÇ?:>_ú÷¿¯ö[;œI2_±W.‘ää+ éNP‚LhI Œ"/„À¾À¤«dß-*þ^C¹É÷'g¯—§L¸UjöŒË„dž—[0üíÕšŒZú– %­ÝŽ b*͸²Û-ÆÙÅÏü‡§W'>ùè'\d"Ó¬Ýlö ûþf™ÏrÀb%X°ÃàQr™pLl9 æ—Áõ‚¸C©¤[€Lk9oT*f¤2‚‚$7*Õݶ]?žî‡4åN)ž±¼ÂP4dC¯}…SÙäQœÂoßZ¼Ä1lùŸì—<åná(SkØ1æ¡‘!BäŠÝlûeÂUA‚¢ˆ1Ób® 3Tó9§ùâbZL$v­B;6z‡ë|ûª<õÍÁóg*(ÆÄL —Ï4z ‚7¯þ~Á—pK±¦yãÿøáŸHgá‘#ï=¹øðáÝ‘'ÂröôÐ3½ÖûÅêä¼þKÃL¼?öù'Éõ’Ffš›‹äRÉõE.ÕËn¸(Cy£2îDÞ±Í$ÁtnJc ªäXúÐ-^Ÿ®Ž–˜>·xýå ·x»üóܽ»¾"¯]î-žã%–'çgäºdNüÙêâôhy¶æúß¾]¾?>übõ§ëk•ñ~¥qú_žâi*j[wìë|†;ïC<öÙ4ò¦QãhŒ>uô©—}ÊhÔÑh›F £!£¡£1$·!¹ ÉmHnCr’ÛF29žMCFCG#Ž†F<e4Ö’ßMã.¢DoÐK„r>„F&ΓÉM½šÎiF¥A¶+(È•–s7(‹4¯#aôÉÄI.Ø Ù.@&ö¡Œ.”4[ñXøP˜,D9áºÄY̤¥Ïð †Ú˜Šlƒð¿vò¡d†„½Ë°™Ü1CS°›sÄuJOj©˜Ý*bwb«Ì×-Ï2 fX‡p…Á <˜ìm® 7¶hA¸ñ 2cNx>‘H5ÎÇpÒ+478 ÊÙÚÝcâÙ€'EÔI]àYYÌÑóS‘Y¿Aj]Œ—8L‹í‚cbþëP³^Éê[ÛdÚó3XMM1 uä9B«¿¶&þÓj]÷¯R¢gò¢ˆµxˆZ‘è„1Ïqμ@ðæA®4ò8eG$“Ð1ûLrqâér_“Ïa>Gß*7m(¾p³Â†° D¥øÚÒl8Ö§#<¸Ï¾b|#eÖK‚¡ŸïmDÆÍÖ~6¬Ÿâ3yÊmNžìÌ%³rs­£„Ð{Ò’¸§7Í£z¤q»‰–¢¾ ŽÙM4£¯\î¢,÷C™Ö~ÎGâ§V=ôâ§- ©‹Þ3'yBÞž¬Š?=á÷F=w¡õÚRFqvôÛÅ6âö®¡å½à««¬ a]}ê‡í,žõš¿ÅÁâû7/ùóä·óóû‹Å¯¿¬N]úã“ÓãCÿËéâãéê_çlqv´:?úmñÙ &1ÝÃ$þìц endstream endobj 1492 0 obj << /Length 3517 /Filter /FlateDecode >> stream xÚå[YsÛF~÷¯à#UkŽ0'où!ë8‰wã#–²U»N@Q %+¿~»§gp¤(ÉÙlÕ>Øœ st}Î(˜\O‚É÷Ï‚Áïß.Ÿ'ãIÄbcÔäòjÂ5g&iÆ%Ÿ\.'Ÿ¦úl&t0}qöëåß›o'ŸfZ›i½J©÷mZg•0ÿô¤Ä¡¾òñ{ZL³8 .¦B 1‘, bZ)ì-1Ø›f¡ˆ'³ÎðOn8,@kaá#îm*Õ`·Ó_iŸÛdñ9¹v›†Ûß]•.]Ë•V¦gBOo²bWåw®oSÕIžû¡s×Üf)©T@[y›U®£.Ó¤öŸ%nÍõw8Ó’iÍ'3.X¬Ð!ý7ÛmY|ÉÖ0µcA¶ÉÎøt½[SýÛôŒëéu™ºþÛ¬^¹=ìê¾ËTým—TÙl™nü†ËK•eZ§‹:+6Tý%ÐÁOß¼ý~ù>‡ Üq¸çï‘ã´{’±˜.VE¶H©Œ”Æ_Ki,TÅU}{Æá ¥kYîÊlse9M6I~Wá®°g»Jª”ÍBi¦—+ßÚN/.yîfI·éfIe<¯_¶;áŠñðÇ8`Q.SZW)á¡UQm,S*%g"˜Þ E“,OæyúÚãÀ®€ýöXJIø¤.³/Ôˆd®ï¶~ ܪì÷)ï¦hÚs‰éf·ž#mç•=AÐß< g‘VUQV–iÐ1#áG±X)óLL£ä»ÔqÛ’þTt·"m‚ŽHýÕ¾M¯’]^»õp-œd TÄ´AA·Ÿ¼&›l£-XOØÐÌÍÞÛ֛͢XoaÊy–gõÝÈž´ba,{zóêÝ帣p_TÖi²Üä@ÿ¾Þi”É6)Q×䎬 ¤»³ÀÙª´#–÷ª_Õ=«@~G¡ßu³]íQkŸŠGþ×ÇŸÄEqÔ§ïÇ4oçF­•¬Aë”(âսÀ ÝÁÀƒÎ­™Å)§¾ï0¡fZÈáYÖIùylÏ’3ö0óéë<¬å!ÔnW¾D0€jÐé¤d°Áò~AzñÓ›li)-ÖÅAû­µG*˜‚®AgΘ`øzWÕn׿MË«¢\Ó¼`çR¨‘œ¹CôôhP‚‹ÄAõÊêåE]”Ùï š Ö(ŸŽ%ø7_”D§YšùNª*]Ï›k5ä« äÛ"ÝÔ„˜T£V8µÌ*?Gý»„5~}ùì·g¸º ÜpJ1ÑR3cÄd±~öé×`²„NØ6“×[;t Cc¦¥‚r>¹xöÓˆ%%Xñ ‚ÉP¸è MGf¢ú^¹”,­\­ÞIò| _Š-òf¨Ë÷L•3 B & ?™‡ ªÑ,iž®K G8!XŠE ÅD Žq„@"q„‹æ"¿ñOåw&[F!Xjô'¥é°+펦~˜¦fk౺ºuxt<êTà÷ääµÓû¯ÉÂè/¾yš,I»DjZø sn¨Þ5¦Põ^–çi}›Z}ãÁtà~±@ñ€-"ÅZ¸Áè€Ú­”¯¥æ_IIÎá€Q=‡§.ÝÊÞáñiúîG£tœ7ýæê ÇžTŸÝ§W£ˆ6XŒ­DC/(«›½‚zè_öa.¸à*32Ãå1˜Ç€7:¦oxÈ8ÄCà ²He˜óøž!Œ¿ÂýÊŽÚ,Ó)Ñ5©ØÅðoSÂÛDÌ”Ñ~ÄÛÀ4δB2šÐÖZ“¦€€TÙa‰ ™Ôò˜æÑÈ@Â\êrýghžxÏ6Tß9Ha[+–PA$ЖÜظ‰fE !}MrõÅ®,ì~®C¶ƒƒÓÀEØÔN`1n‰N‰*†è! ôlÔ#°£E‹í.hk­Øv`Eè΃»=ŠEÖ»9†ž@z´`A ÿìßaÒá— ÌÀ/§> ÔCúIÐwuDíÂE‹1¸€{©2rÐÏ7ƒ˜ûpqyU¶Xùˆw„¬ïèwÔ*¨ù±ù‚öS—ùcñ˜¼j!¦ó¢:®¨²H*´ˆX´á.ô´>2¶¢YÕ‚wÝ.l&LÓI±#Nl· Ç†mf3^ÈXÏMµLÝl™[óÚra vaàћɚÕëŒûíGÅa’Rè­(éò<ÐtUä9¥¢(¹ƒI–²€ø¤¾£Zµ*vù’¾Zùò¡  5ÁƇ×ßîK·Œ ‹ÔD¥•RnÁ¬‹ÐíÞj2ÆèÁNÄ¥q¢ùî€x¡n”ùµÀo..ÿùÍÇý*À±‚øé'TZ1pâûG¼xõÃÏR}ãÞ)3DE‹Œ—;5¨ˆñjãÝñÔr«ôfO ñÅ›¿ k@B‚ѳy}9øƒ1§™ÐMz }ÿ’=o]J'½‹ÿ CËl“<~jÁ²¡ü §È‘O:µ÷E €ñ ¿çãØ™¦“aÀš¦F¢© ‰oË3N1‡•Ý¤þ® ›L?S0ým5æ7(¦!ƒxPtÔo_R ‰Ô?.ÄÜ2æ b_ÚÆ„°ømJ§Ye×+|B¹L!\YS¶[˜6X„²qg'³IDq_UÙõ„3‹ÄZr"ªÀ鼕ér·HñV­Óø|2j4Kôw„ë®Þîj\žÅb:»xõY}ùêÇyÌ•Ò N¯D'Û€ªè^ç=ï¿×¿ô8øNŒo×â³|›bšwøÈç¿´ÓCðcʯõL+ø#ŸiýŸ>#RFSžDD<‰ò½ˆ:yñ¸< X‰ãZMZÇGN¸”, ¢§dÉÁ‘‘’fÒþ¥ï y¥%J€m¢D…”(¹D ’j˜(A:Ôç‚άKÉ.W›=Ì Q¢ŒO”@ɦ6à÷p¢:ŦÊÈͳõ&U¢| «L7U‚K¢%Ç=‡ÁÃsHuÕf#NObÌü—=jXšqïµÚø¤ ·y›` !–0¼“ÍÀæÃÔÎîKãSA‚G¤’L!ˆñ-@ü +|áAé˜?) @ŽJCõ—¾fÃLÍÍô‹xä#ÍÙãN¤i™påb,‹xŸeýð“Ì¥÷—îd?ülœq'3X¯ÒôëEƒ„±K ïüM.ù¢Ì¶û¾y?}•™Ä¨)Žf8˜…À¦…û¹öö­¢Ô¡ìüé‚îTp  2†€àƺhèBûú<ñ¥†Ú9ª¿Æ8­êzûâüü:OÊ¢bËzÁ f£œ_^ëô|ï­ÜÿÅMZÞdéí>ÚÚé…R+ÑK?"#çuâžøpi‹‚ywfôôÏSÇda¼E3`ñµ¨Ñ.¿"Å7ÿÛ>;| endstream endobj 1542 0 obj << /Length 4504 /Filter /FlateDecode >> stream xÚ½\Ýsܸ‘÷_1÷pU£: Á'¤Ê›ÔîÆ©¬³g9IÝ9û@ÍPË3C-9³¶òק ‡úIwI|w£Ñ?ô˜/®|ñãŸøôæw?h¹ð̲X|ºZi˜4jQ8Ä‹OëÅç¥aš‰³sÁ9_^Üm·Õ¾­WgçÒðåmÕnûr_7;*øíLðeµÚ7-}ÿ“~ö˧?Ã<|á`žB‡yŠ‚Y¥aa†÷üðé/ØÔÂÛËQ{ Ër©u¹[ÏÉ oŽF”>r U;¦E?æÐHùÑ çÒZ&¤]œ ˸ˆ ùÇMäja—û› _ܲi×U[ﮩ¸îè¹köT}Û6gÂ,«×Õšª.ï&#ºª=Ó|ù>Oåv¹ºiêUšå*ëd³iݲ۷å¾Â‰®ïò…¬šÝ¾m6šÝáì@,gþ™E‹‘>>þøfÂ\ àÌß~õ25a .˜ò=—k`›²f¹*» ßt Kºê×CµÛ×冾Ë]¹¹ëpùØ*IÑÓ,„fžÇâà]1Ê…Oß l{‹ xa=§²Oƒð(ÿ€lÞ·#˜µO`ßmÙ–°»kq®¸cFç[60TKõ †*ÊÂ<—Ÿ= ï$¶ggçNºåû­–Ž/26Z!œˆ X… Ë{J©g¤ 7¨0ãã•«f{{Ø‘‡¯z·¯Zh~&–›;*‚1¿œfÜ©œ_ù‰UÆ„«LA‡ F'V9¹¼XÝZªÁ™7Õ:Ö•]Wm/7i¨&¶«¨Qzy[îaumý-ÊöìgëÍ‹mÇš‰˜œP Ô¿¡;)f § ø «èRÌw¬H­dÞõ;ýÓß~úùbF3JÏ„©U[mê4l2uün«ý¡Ý!éaÒf²°ÀEê°›TmÛÛ.ÈÖ÷ŸÞüúgã ±P΃xƒ‘’šiØ·ÕöÍç_øb •À‡ o¾†¦Û…›/›ÅÅ›ÿ&s—¡¼dRÑHÒé¸óeûŸÿóÓñ¼Z °¯0­VŠ9‘Ïúó÷"ªË¶-ïÎ@šYv¬Ò·bÆ°á3*ö¿‡W€ý Rp Âñ‚5 ã™+h kNÍk¯ƒe¥ðžIý¼eesI.˜Wù²+%Vr”0êT ÁZ¢¢™¼m‚– ÙïC´ÈëÎjÏÛ –\*?ÌûáAuÏTî‘ŒŒ¸C5Ù¬Ê}ò ’B Ú «w±¢?pA¹I)ÍD= æ5.:@ÜMÓí©ߪ꺠oá“Zúes؃2½šIï’ôj´/Pp{š´¼Wfù>öB¤¬wݤoæBRM{|Eg²ì2ý戀ê õÙxš5¾ü†ÛX!'”u#ů,ìÛLÖ6µ.ó/ârSÅ:5Åe`í×z³¡2PU4Sl»—ôyYö^ ?žpwØ‚iZ•›9m}E¯¹þWà°Î X§œ€Ïî°º¡·¸:x›=_ÒLp³0Ö0n_¢«¤uÌz #iæìHY…DBŠË¸i6ë.­­¢—Û¦«i_ñ+ø*ð[¢H^|ì¦ýãÞJ0*‘Ú`áÏLTŽÀEÐÉ…œØîp‚kµ 'ü[‰²÷pL[ÀO1;B¿„cR1Îq$zÐäÁÿy'imÛª ç^£Ôk9áÖ‰ØDmcÈËu½ .ŽV‚{ð-6íh°¾iWÁù‹*„Â)›ól2«$KÏËð-àxÕ[˜ UærMEaA2Zl|™ìv œ>>X|+i°è?…ºÞ¢ï¤ÂG‹¡Bý:ÅêuâáOsg“£¦M”Z9R¿ð•ûi¡ Üt ½Õ»Õæ°F· ¿úþýNŸÉYÃÒ«¶Ùf ‹Þá„ױö8.3£2Ì[AÔ~¢÷/7ê“vŽ‹…)AºN³é™Åô¾x‰+—õûöE fDfÝO£Þ>\üËû‹Oÿî㌖(€8¯^H‰ÚÁ©œÈ‹?þéo¤²`Îç> Š`Ð)ÎO¤Øàk¿§ïÿ÷ûW[A{´#/¦WiØ oN§·§ö¿jãMGo^‚Q~†0À`›üç¿þá¡“¡•Ð9THónNá[`£Öè€ÞÚ†bøŠ‹$ÎÀË#„Ϲ¨@q·üÐìûžåž† Ã^‡ÝŠv²ÞßQQªjv›»è€š›z€%zmä|ÔrQ²¿Öû› .3kIøS05>g'„È`eׯÖÞ›DÃY:6Ñ ï< —ã&8’MGñIÀIïñä7Ì‚JÖÊ&Ð 2Oæ+{ÿaFŸвâ~àÄêpcàÄ(þ|àÄ1î‹ç'°:…øb\ÚBÁÏ]|©w5Šsý¯Ts 2ÉËÉI Á>*>SL‚%}*ø–Ž:6ë«ÇG¿‡#„Í¢Êgh0Û58vOPacsööÄM² .‹—_ D݉ÅÛµ“q®€ ÔDtÂ%• ÞQ¿†8š^~·Ùß4‡kÔ~ •n°mP–"n|'Cê¢ÆGô"7œ.Z7¨Ý`q¸+…âÑm£¹(ãDÏ rÏ#]ó¡®9+1Ò•Þݧ˜ö€Y4ÇË®—( â4ŽÑŽ2½bN ŠV‘»ŽÊÖÕ?9—»*~Ær=bA§‹·´øêé‚dÜ8» ”Æû[l=;$a)àâÙ ûidœF¥dÚäeŒÛå'*Wɇ‚ÝfM¥‰2ª™g<úä……§gß¾ãWZ2UàH†9[Œ/#öH´XÞ· ö˜WX†síµ™.¨{Ã6‰eý<ÃôŒà…äXI!¬’ô{ÆÏêý.½˜Ø;쥟tXRÇuìèsèŸÃaa¦U1`•X™c•Šß»åN2á$+X‘“÷ÿVÚGp3]°‚«W Vk`ÞÐJáy´ò\Iϸœ*ÉYÔÒ«GQKÉ´µà^ˆZ>Â} ~Ÿâ>½Ò½ç@²§¸O-s`ì þòâ3øù2ƒ%ñû~XòÜ‚Sø>6‹X B)-OŽs“àk”q_Ï@EÀ}rƽRÊÕÛSC*å`›&Ú{^‹ ð¡$l¹‚=PR¾äæÇÈ‹# é)j/[{p"aPõõbî5Zq>%à*…n˜[” Ãcèfèª3€j@H2=×uÝ.Ñe ƒxœI®­El”ãØ·Lañ‰@'dÞÊhV€¢¿„Y÷%¢ÀU†F2Î?I’$³ò$ ˆ‡¸l}âÙ‘.„]–b@S7^PïÀT9¡^–B[cOV–Èì䆒Ãg´eŒ@‰¹¡t®«]ÕÆø\×1©§¥«à+žê# õˆÏ'!ÈÕl;—ÌÉ—x RÓt8R¡ž¨¬ôõ~Y­J¯™{#¼®®ÛHÁ4¶oµ/¿„»¯Ž˜Ù5ÛŠÞ®ÚªZ£×< A¶¨4[p†¹Ö è¨8F®Râ#Rëȱ÷p”õq؃‡ ‚5¥@I£–ˆ¸Æ»!W|¡ .„7Vuµ[¡Â‰Yà‰åŸ¬þZ Ú(æÚž¦uœ‚=ôi`7x.×B,ü"¥C³á@ˆÈ<Ñ|)3ùeà ô°¼òaUcÁƒ”¾œ:'À¼«œº'h;¸ee¸òÂÍÿõ‚o¿Mˆ–QV’©‰2TGMZ¼D™¢4¯¦”ã˜í v½-{Ã<\ Å{+’óx];×cwØ^¦tä4hñ Ø< öè>læ¢.]îph xâ”sB—î®M¼¹þ9 Ýþü6É~ <ø=9/õ>L?\nǬjlÑÁ€6ëžßÿ†dBn#"É®0 åàÁ×¾¡ËÅz›pë”èÈm ó-¹:´e<¬¡$dõ›tÍæ0üU å^bß]œ?$ó9Ú11´@ÌD]Ú€…I„ÕÊÝ—®_î ø¡þ÷.øQ·|[áõÔi1g…>¾Úü4÷õ™O>(¬f†|\qN>–ôäS?rR¡¼Û7·TTÕ@pK¥áÖ$”–C³[d>él¼L›ž U‹‹¡½òªr~ÙÁò:\ z>~ Ù¬PS^…K>l\Ò›} d¬©I:AXdžÝ¾ºEÀÛJ¿üns Çd³}ÜÝÀáäĵãnV:š!¦ŒúYáò<çî\ÊÀÀkU¤;o|+éÑ33|õ| ¿Ñ°” åuB¯3 õ×Q| .‘xÔ¸gh£ñ0ôÄgÌþ-xJÀUî_l\R¾ÁVîs6\ÂhëüW½’»,W_èÚ¥Mº³m›¶›ƒ#¸erQþƒš@„h˜·¶  [ 6éæöE†}dLÀƒ34êÓlòùÀs'N'g¦OÖˆñto£µˆš?ÝƬóß«\DøI9PŠ)6ê!™æ.&1÷)öW˜"¸Aœ Æ-(ÔÅç¡#a%|K¢ëä,6ŽÉ+Ù‘ÈO~1ØÎ0ÆUE8ù4|*š;¡E~Bß&v0mò;]<˜ †ðೡ’G—0y‡"øSI¬Üƒe‡S¶—N %3çŽq˜›p|^T¡e@¾ƒ÷;~Ž<ÅCØŽ/åKyûüç§# oQ™À[È¿¡Úp’š-p9tO^ßTä›3|›Ñc+’%íôv9ƒ<Péô£«¯wupÌËÝ>g†Oý‚5‰ìx‹â(;)ÐE,ñú‹æ6_ñ©í‡`¯oš5ÕnË;zY×ãh ì7n±öq‹SR9@l;aÆ´M$à*ð#yŒÄö2ÙU8£.hïPÆR:†ÙÂïü åÈEÒE$òÀvôv{‘”´&J÷Š}â¸&%®Ä™ã¸È_,ÿºg¦C}Cî–ÁHhÜ•MFêè‹!‘!°/3ܧ ÛÄ$1hu‚ºÂŽGöÇ ëe<xL!)×ûÁãEýœSåÜô88òŠbšÅÉpbI¿/Ç&4+œñÛŒõ°Ìq9‚“+<ÓÓŒÙÑ9j¿³†x79´·-ÀusHÈf ´b3éc<@…t÷z¬S{K= TÞÞ?âœc¨ású¥™Õ:†_dUÑ|¦Þï~(2$Zšà ei{?‡©¯ ñã‰-Q¥ÉxL™ZÁ¾†lá±Þ“Ùväþþå Ðöˆ}1çâf¨Ü.C„þo}Ûñ" endstream endobj 1562 0 obj << /Length 2924 /Filter /FlateDecode >> stream xÚíZK“Û6¾Ï¯ÐÞ¤ŠãI®uªœlœL*ëÝõÌÍö#qFŒ%RKRÏþúíÀ(èe'U[µ¾H 6ÐèI':ùùŠžùÿÃíÕó×"™$$‰x4¹½Ÿ0®WbÅŠ°º–“wÓß²föáö×ç¯UDkr̘Ïv„',²p—Íæ\Ñi³r¼È›<]Û‹º\ïš¼,ìUy˜/Ñ$JD+î•›0öW”ˆnÄËК)Q,ê–„#ö6e¤ÄœÉ˜ÐDCƒ‘D)ûèåf»kœ&UVç˨²?¡„Â3nÂjÍš(˜î²%?ÍÕ`DDd'á=¥4´wØò·î´ÞÖOÖ»3eZ×å"O›li¯ïÒÅÇǃ•ëɪª¬êz‘€vg´¿Ø!”J´ˆ­zœâ*@K·ð5McÒbœÄ:ºh2~Ædï©¢u–¹m¥¢‚¨I…ûÚ^¼ýùjòÎlÅÍî®Î½³ "÷,b%²Vòšs°ì¡o¥|ßÏ@±ÞËæ\ÇSz@¾äCùøœ•íÀàq•¯³ÀÖr uÞÖJÏŽþ2£XLc¾;åÍgÍÄa£ Ñpª÷”«“øž2„º„vXˆ¾gL»K:ý4c "`ÆâéCV,Zü«íQ6.œÊÒẜq5}tÁöd‘n·ó *°d \V ªñ ¯ß‡øéöêßW¨ °‰Ð ‰à‘H ¨Ébsõî,áæ¯àÖ"‰'fèfÂIã|ëÉÍÕ¿™EÄœD<6¢Däµn²­CÏí¸„ýìö|YžX\s"Xì‡ÂM¹¶ÛvY*ºY^…ÀYj>€VAù( ÆÞ}±ó¾ ˜ <µ÷÷]#ü]XTv^wowÑ”UþŸÔàÌ9@iB!x›÷õê|mjBãöþw°dÎí-‹AsåÉÚÓc2—€<Ê_øŸ–hãs2­¸0Ó I=F0.ɧT‘ø$:²?2Ÿê‹&ãgy#“œ0ó$‡;’Õ wÚ¨ ŠDR¼‘•  W~rÌZäï²äIfâŒÄÖsÖ¾Íj3›Ë(šò!Áøž[^7YÑŽ‰Ãžy²ÊÀQy‘m²¢!³y¢ôôUcoeébe[ÃÏfsÅÇ®f†YWƒ¶‚N'¶G¼2 ¯í†1îª)™»e{Þ~ «BÀuXë“BÌ3#:DrÈ>Igƺ)·[ƒ’"I¦ ØǬr08FV OCò|?𦦄²NÄonC1|Àf–° R ff`­âé-‚º¤À v›; F(ˆLŸÍ—¦k›U÷eµ1{M-›Àîu¾É]ð¢5€¿WT@ZSÇÒ>ÀÑLNø8ÓeYß›L&œhÈJ€¾P-Ž³¾·'Jª†Öxy™-`'b¢ãQ»nÂè)«(Aô5¡UÎ âý ° A“ˆñouôÿSíç‰`}8]VAbMy$crž©åBÒJwD«qµE(Ü¡nƒ4M$p@®ñ,ŸÅà¬êQ”h «›Ã,ŸêäB–MUì§Ýo$ÿÉÿß#ù> H ~æ+бÅœŸb0WL0HR´ÇÍÉRˆ5*Ø#%°F‹Ä=kt„ĺóû‡>›Gœ-_q‰Ç¦#ËWv€Yä$Áü5Ç $-*Œ(¦ôxÜrÝ÷Ž(¥G㹃ï0¿Ÿä#q4OtÔE¡!%ž+6$=nÌPòÔ… (bʤ¡”1Íñ”BqÒÓiÌÄ`áúËi!1HƒDfJ%`C ¨ü\(`EÎ8ÿœÅà(uß­×}J«<…«úyZUèZéSÝrsŽ0Ÿ-»åö0`Ž‚uùâÖØ? ɯOoÞþrsT×±n žŠš qKyX·õ.«k‡x¤½å^ŒÌž1˜+‚X¹?Õ_­L5\°wÞù L e{Ïu^ŒŸçJEÓ×ùÁ=cÓ.ÀÚÞü4¢@¥# {½i;»rͤ¹®\óNIwu¶ôϦµ)Ào•5£ƒ*µóX!(eyÌ Ô°ÜMíªšïÿCü=ýœovÜ2ÝׄÐÆ Çÿ¶&t4Äî‘ ãÀ‡œŒ®b†« Œ4'MU¸II•Aù駸pC¤¤9±ITâXgV»üƒ/8_–EûjÉ=o+Úœâ»\_ ›ÍÒ6Q’¹{ãPÄ ?ìþ–ݧ»u3î€u¡âQÃØ6nOû„T”g¯ûÈ !­nNo±o³uÿrn›ZlÝd î?lh`嚮ب‡ODNi¢Q|´í×…9bjò»|7O!<•PÂRÁ\Çñ4¿¿L–ÉýÌmt`áÏâ’u¾d3°Gb–ºÊ{>âÆg[<‰KÀÝóº©ò»œ;™IÌ0 ü¿xýÊ ª÷üË€î1Üç‚"sE|†P…­Hæ"Ó宲Àí½¢Wƒ{,2ªâ˜‹UÅÊ€'ó÷¹9>×þ>äú„õ¤ÙE¡þ÷|‹ù{ªüaÕØæÊb«Î—Y=Ð €©¸ÔpŒpÁö wèèjH²(Tº¦Ä˜£Ô¦ÊzH]'= ýèK6iõ1„°t¡‡‘'"IלîhÜ ƒåкÔÄ2›éóöÄ3¶ïÌ!¦{ÕK%hI¢¾}æ$po€î•þ= YûXl¢PÇäáy†ìº-ƒ]5Ùw7Lt4N‚Ðcó¹VýQò3Ø j(@Mß“°,wèòLNÓ%?Ù ›ä±eù‡<œãñf{Ên.úŠõä·8\„¾“@*Cùôve‰Šú–¦)œÓ™U®Ü”Ar$GûcĤ&¿˜lÄrð¨Ó Âw“q*lØQᘠ4ç²x»»¥ÔnvÞe–ãýͶ*q‚O‡^\yâÎ 5p\Vµ»¼¯Êm¥…˜.»*]8[ám™ní¼ŸòÌ~m©)ñvï¢~@«s‰´Òþ¯ €@ã.Ë ÛªWö“wùÎ٠̘ÆŒSÎÆ6ü€ÏtøO»³h•Åúɶ«¬»hÿW:’Y€ iY°]î~ H=3s+¤·\-Ò"dÿò¾A­¥Æ‚2Àý‡"G©ðHƒ+Æ›c#|)Ƨ7¥»}oŸµ~Ic3Êƾ‚(\/m¯ùtd¸Ë›±çÑõT¦9iÂnûFh¬R9";Æ'÷]ŠýŸsG»“Ÿ‹Þ]%˜E|aXvÊʤ CCuÝmÿ­ 0¤ÈY]§Õ“íÇIŒEkAøId#ÏMa^Nº‘Eº~ª\QnœýœŸqx»Ófý¶œG‡Çó¸öÌò.»v§Ù]ÖÒ¨„ˆh„¶©98‚ÙáŠ]á:Œî"X5àý‰öìï ê<¸ruž).Åm²©è 3€6ð¥c, ³èŠÚâ¼âÓ_,ÒdC†¸ÁÊTa(bÌ˜å± T+ÌìîEzô¢{†ßTx«Õê<úÊÊE­ÝWZ@¥BÍ[èÑ7Cf)ñ•o?¨û¨Â›ŽE@“˦ãçL·J±Âè|%j[íÛÜÆľfwn¦€ºÉ×kÛ¬²fW™Û»Ü‰y{ýæõ?~F'ÐÎãññÂU ê*šŒ*†þ‘ØQg÷.p›-†Þ ¸êe¨ä\££ƒj›AIÎ, r/ùÂ,’³…x8tx:3Ö6z ÓETaÿ0zøE¢¤«tYôð„ˆÚ:á°WùhíÇ-8bæ4kH÷úÒ%øŽBbGºQûÕŠÞ#?Ý^ý­- Ê endstream endobj 1460 0 obj << /Type /ObjStm /N 100 /First 1001 /Length 2909 /Filter /FlateDecode >> stream xÚ½[[sT7~÷¯Ð#¼h¤nµ.)*U@Š„­,Ia¶jwÇLÀxR¾°Éþúý>ÍÈŽÏ0KŽO…Ø}ftZ­V_?ÉÅW$»”ñ«¸&.&3µ’È.ÖD":‘¢E§‰Dª®Äȯ‚«‰ƒst­–à…¯euQ2GeWªsq ÔI™TrR”ssR×ïf§!pŽRœÆÔߨN¥p¶Ò°  jpjÆw+V˜kÃUœV!çªN›‘ ´‘Bã»Õ\ᡤ…\š:(/B“D×eà ¹+³Pà ëÃÔSdgb\Z-δvª3ëê«ÍYÎ1>+]} Ÿ5!—\ÊBt9bg@‰ËJ‘-¨Ë)c Éeƒ Ìå¢Ê.×ܹWXâŽÂ@5¬€F`Æ¡\‡AÿŸ\ƒÉ”Ìý´¨®ÔÀ9br¥ig®*ÃbvUBçR\ÕÔ?«4J›«9’ô_‹ñ[‰®VêÀD\ ±Sê49 ’&}•b®A÷¤²kf”…¶‹%‘ª°Ã®!XlkÜTSˆðIŒ Òµ@[ J+²„ñ :Èï-qÛ©ÜÀmÚHÈ_4’Â6 ·(z…¥NÒ¤,q¦Š•dšr¨4mãÚC‹œˆÞ¦\eˆÚ?¥êÖîf I¢õuÒlbéJWLk×:-¶Ö ŸJì¨@‘î\´'I| ?Ä43:&Ÿ¹¤ ž»çè&Þ쬟¬N/܃nñ*K°ÚþÖì@Š2ióë¡É¬àlVÇ0£›®À|ñãÙêøpyá^ºÅßÀf¬áóx»(O?{ñý«{R_ÝŸN¤y86sÁ\ 6 yÉ #ÄÓùQDÄÔ˜’±9p­Á3J ¼ûÓ.AlR…@ŽY$vEMð-Q,ñ5Ëlb( $`_P¯ø€Ì­†›…Š<2Ñ.9b›T†…³Ê‚aT$`¡øøეùör ˆpˆÇØír h`ÑçcÌómLQ_à(Hgˆf• ù“•iB¹]?.Ï>>=2z `•v-"k@êÚ%Ã÷'矎Îß]žM'IÌɳHŒé¬ã>RThåöðñlÂ鱨YÇì¨Æ MÛ9ûáÉ—+A²Â5®¤ÐX< Ù¹¥0D*C H^a‚ìÊ& q=éíáóð·´Ì ·#el‡±Ãó½Ãlð 4> ßµm>úìÉß¾ºW&ÐÛ@äcŠ‚¿mgN‹2¥Wú@á‰Ñq·³h!y‹ŸN¾)hq, "ûÌ Z@S¡ð¼Í<§VàYz¢ÓÀÎÀSsE †ôÚÌ—-5àùåOü‡÷OV§Õ†Pl ü ·H‰_ÑIŠe˜l›±ƒƒ¢’eÙ˜vIž³Í´;›"=ŽÏp”Q¢›õVóŒÊ€ƒ4âSôT4Cʪ«ƒ_£óh#Á2{yÖè¨4,@;ÄÏ9ÎÅý|¡2Bí½‚Âgrꨄ/Af2 ;Dß«drAQLÌÎS¶lÇÿãµÛZ¶xA¥ô §F‰à T@"÷Z|³œ¾šÅÃ:ûÅÃ>÷âpñçOùÿ½w¿|µX¼ýpt¶:÷o.ŽýåÇS¿|s¹xûþÝêãrñqyqr¾ù¹ú´<ût²üÏýk¡;Òâ5‚.M;|{&óûט ËxùÜè² …cµû ,7à“Ë_V,ýX!ÌöÅÀJøEøEøEøEŸ´Í'Ä`7D„ B‘aƒÈƒ(ƒ¨ƒœãàç88ÇÁ9ÎqpŽƒsœãàgœep–ÁYgœep–ÁYgœepÖ1XÇ`-“b7ì(°wˆ?^ˆð¢ EMë2*,d‰]™aÚŠ®"¡r-h0è=䘦`$ÂÆAòvҽ䘴-h{1ï„&!QbðÈ–K½FQ!(œxÐÂMzûÑðÌš[Ò7€› Û•5ÚOԸƞÔXÀ̇’ÄR=¦à¢žU$ *$Iž/yÄ®¹ª8TmW õª¥î”àn æ«É„À“ÜNULß ³Ë‘rµ!D«Z,sK3QC,ž@ã‰.¶ùÛzY³µ~º*žbšÒUö…g£Uý ¸øF öìVaþöã)KIé1<1Dž Ká)ãÙfì2š(ÈÀI³/U%COLªè]Ç,"Û ³ m8H«èu( žsºû}è¨!ZÎ! ‚As—w²#xS Ê“Ø \D³›­¸¸’#¨¯í¶"€×Ò|Ð2{þØèñ0HÃ…žé´ãŒ?ÖÏÃiíY91´R.Bíg¸Í6¯_\É€–Ëxµd‡ w“Ï’¨ç±ÿ$Än”À»$¹‹TRY‰C=ƒ¡àÓcå&á¹É|(s!`w%†FäWØê.1î,¥1€óêÔ†‡e5ïÖÉF2e^¯æ"ÊÌÌ‚M’-èûä‡B<¯… RA³¶S†>¦M¯1vÜLÑ’d‹kÇA+M4~žó1…‹ònÔ «]ýv ¦¡uÕx-B#xWvˆp§p·Äæ‰*ózoW¥Â6¢lš)¢l ˜Ôêy%N“uçh¦T™GdÖv-BOø]-ÛE¸ƒ£^ÑÞ ðŒëo<+žmgÕô'ÙÒ›T¿6ô°Ö¯Ùá¹Ý^ö}x»:þÙË´Å8cvlp v™‰ßI@ Tö9Bó0¥<½“çYHi ò6noxv·åbÎF):ÝM%âìl"¯á.Ø ïAB¸¸å¢ßT::{óæ«Ú¦½vÁ[¡Äyˆh c(Õ•µím#„ºyÏi/ýÆÀ«“ÍФéçFó¦d-.ó„ÂödmÁ7zsÁÐ/eÛ¡ÂÓ‚ç7Ž,8+W„ùÊŸOOx{ssñÆÅŸ=ä[Îò—Ÿ=ð"ð.@¼ ^È®d7@-OÆUP^ü݃ >6¦°ÑÛÀèmúV§ëJÑdøh$4Ò<Ôär&6šç¥‚¨Å¿@ Wbu ¨D¥ƒµyË]ºMu>iqëHá"ojgYŸë¢PFÆ™/á`1vŽÝºæ]¸ ÂO–ÿæÊÂNZ’^ý\—çËmüõü»ÃéïÔ€^6GÏ¿qá½Ùrßà CP‹+FoÈDL6! f£ÇÕ´»}Œ“,4 I Ax!!Ýï!ˆÊôÈÁ…ìùg¼9Uy±ý­æ,#šVøê`ܽØ!À-.ò?æB endstream endobj 1607 0 obj << /Length 3105 /Filter /FlateDecode >> stream xÚíÉrÛÈõ®¯`nTÅj÷ŠT™TMO<•q[IŠ YˆA@c+_Ÿ÷zºAp“<“r!{C÷ë·/MggtöÝýÿîæâå+‘ÍR’%‰œÝÜ͘’„fj–¤Š0Áf7«Ù휑Ë7ß÷_Ín¯”JæE¹¹/ÚË+®è|sÉæ÷…m·ÅÛ¢Û+ÛÍ—Ëm›//™š?Ú‘²ó óå½_öOª(žòò•b<‘ŠÃ¹’_Ù%<)’iàE´³+J²,qðºh°QBX–΂E¿ž8-#œ%ÇÎÑY|b›„hƳ~ãðG «Y‹ˆôwß$À4ó`üþÍÍŸ9~XD‡é„&‰ê?ÛY=»âŽd|vÅ8ÉeþIÚ6Ž®Ÿï‹ÚQØ“wÙÔ—’ÎB‚ùY:ÿXÔKœ”Ù¼Í7ELäMÓØFW5—\Í?&wÂwÉ×!wv ¹Õ“È!>!"áY«¦p·¯›m¬Š%°{ç³p’»Ù ¦\3·w— Egã ÑÜÙ5AW–ÄYLVq"Y $ã8¨ vP½ö,Ǩ9Í’oS<¸KÝç—Ü3€»Oá÷{(Ú»¦]+sþì*!j1I2šZÐ^ÃRœ`8JðxòïoF?ãÍÛYÆ:»È­Vóz»^ ÚÁ6b'ËMœW"y°pº-pëºXµÛÝÝžj9ðt±ä‚’TõÌùúÍ«¿|gФŽ‰¦L‰di$šœuþhY8ˆŒøûmîóú<¯¸®Öˆr`HPÔEO•Xv—|ÆlŠÏД‘àY„JmW*’\™”Îß"w4ÝæêÁh‡fYt]Y¼†+e‹ÖŽ:NÌë¼zì@YØs«P¸Àœúáo?¼}?!}‚ pQç‹ yF¦ÌòŒLù|Û!FÍPcÿŸÚée•ˆ`¢æyeGÊÆ}ÑChz àÈ•]z0<…»uåj›W1˜ó\¦(aöŒ¼Zn+TF.Ô•€ÖW*•s0žåÚ(Rì!ã¿9ÝCÞv®½È—ŸŒÀäí G„‡'·ˆöÑÇÐhÚGÛÎë•m¬‹M[.;ÛYƒUÍCáÖ”¸[Ç<À€–±ñ5ÌœÓíüƒý9¯+Š#œl ãývÑËMÙ8Õ"ˆ ||²³U5L€£0bû»ó„' 9ivLf%I¯¾±Ðòö—µ×  ¢€´K§Fó¶·¨ë‡-øK×£3@ÚÁG(ËP®A¥Ræ5 Óãb§Òì<ÇN1pîŽïz¨'PƒÏv[‚Ÿ|þ$ðÓóÀÏö‚ßûOemŒRé¥Ú¨¡ÐÆK/<ˆ~¹vNL’ð´×ØŸ&üIÚ/øvb`)6Ú@ðϸ>Ê& zT&!¢Aí–Yïø0¸z® 8\AROˆ›‰SI€¬Úw±ô Ûá y %ú¨|]òºÅ© ¦Ú…ºë0càÇ…|žL0¥ å}™À•"œ÷ ®' Ã5“ŸF ˜fOc|ÌÇ3I¯’^%=Dž„Knt7¥ê9¤ïÀðÔôþÆõÄí4øcRÂ%…>MHËF’6R°ÐÚ¥E´  P*1æ‰Õl 9°.ØTùàZ/&6Æ­ Á,S F»¿ÌA/þxsñã2ú*œe$`À_#þ—ë‹Ût¶‚ÉïÊ"KgŸÍÒõL8ªÍjöþâ¯.WBÔïÈÖizš£œô”»‰(ŠrŸ&H*Cùû:$=â‘x¡Y•„Štx%^¼0À…cÅÈ:ßÉÓŠ=ÅÉc6ƒÔƒ‰Ñ {a5ôñ°Ÿ¯V¥õX±‡Á†ù7±+N/ô«û•…^á‹0,f&ÑnfãÞÎvîÐǶ®ÊºÈÝ`÷qîÚâLƒÛl’è÷VGQ›™Ðrþ¯­I=hw2YgÃÅþ0aœÀ¶&óC‹fëgñ ÷(‡àg\p2¹8°TÐë-• u‹ ¸jìP[l¶m Ëñ–£ÈáÄxãöJA¸zr˜qÐ=gœž=Ã;GjOH+vM]ºKŸâ¡ë=b4ùÇf I qÌ1÷Ywx–›>)¤îpÀÉ u*¡ÔÚJq¢‡-½[¢¢5šÊH·jÆ÷èO®ô³­“)p]‘ê5ãl•>`ÍD±,á°ØXìŸÅ—Ì;ù’é“ŒD,[Š`24=Wr9•=æ éÆXšöäïõqÆV“ÛMç¢õ×ÉEëSJú\½ÂŸ¤W²À< E$Ɖ¡|Ó˜(Ebפ»¥×ù0äíTAš 'LÎD&~¥ÍÛ¡æL{2’>1©ÃY˜ÕÙ…ƃٕëc±e^oªG;¹nZê²éúQ“Ê ï” sž€Ag(¢,6e÷}Ñ ÜtEu7ddãLiЦ{/9NòB NÕ ¶åE×B©(M…ý¶À¬å ;‰õh”2Žþ;âT~Éæ= qÀ$ç•wh Ñ»(0 . ¬G/Åv=*VviP’a^gÖôŽé·_¦Y M1ÐmwÄw{1ŸŒ ù’>‡!#;“À1l”oœÊU¤ñ%SÉ y0Y1u³”°äн€¨\ºl ’  q‚“4&`³! ì-;ZUFy>q»S”~ù*‰*ZlFZå­‹ÝrTCúÁzÝK,Aø¨Ù×Þúú¾ékoµ[ÓÔ•[µÚ¶&‰}1®­y!0§ÝÅÁ¹Xo±JÐt]¹¨Ü†?åmiÊ/s¬–€¸=v>ócj¯p~±š §8x¯;÷óîOïO‚ÎyOSàUÛ¢›ÊýhB%‚2¥â$]Ú ¯§j•µ«{‹,.@t£ªãP\öŸêl—ãŒâ Š¦ì8NI:@ª*d ™í$÷W" +­EÝuÊ0 o•O‚Iô…9‚E:t´ëΔ$ÔP§zaçq›¦.êÍçÒÚšq] G  Ý. ,óÙô´ðunéebH”*S—‘Æý‰å$.¼èùÚyU~BŠ¡ADlÒž®‰nsÆüã k+XéWþý’1,n=$«òÁ¼+ZSH6Ç´K¹RWèa/FðQ™gÓùð*ÆmMOÒ4É?wù¶ÚÒ8eãS¢Ba4ª€ž' û…Û;ÂÚëùöZ”U¹yœR›e¡r’”)>Û£#ƒc¶£ÜF1¦Œ†âÜo'}:xÞ&¡Cõ¼<&0R;fQðóªíß ʬ÷óq¾rU®Ë_90SzƱÞ:ÁGË‘òß9 ‰“U¼Xsî­Àæ‚+Dùž×œ=å~öéEà+éw-àǶt ¦X¹DTf\gó=ÿo54BÛ`V¯Î|õ¡ÐµÎžAê•y %ßú‡Q“êàmàÈñÎ;èÆæÖaX|œâ=ÁñÚFø#;}">¢úÍð¨[‡Io1¾Ê:o?uÓ¯<„u‡†êƼ¼HÒ wˆ½Ðþaßh`lô9CÓCs)“ ¬Ç cÙl;? cdȼ!@«E)ÚLÅù=g»9f$$¯ôLäÇYÇqÆQÆeT–Œ ÒÜfó÷—”dÒkº×ø®$‘ÓÑb\ãDìDT#¿“pÞïŒO JsÒŠgØç'‰ì+—&ö³C¶x‰-óÒ%QýcRlãJ[Ç61mÛAˆ%‹R„úÙËá'”!œOØÑr8,S<9Þÿn=|çfeíž5q S±¹ÉY’}©#cQA[d¾ 3&‰ù:G´qz°"8·‡%8øxB²c5gþËÔœOxGÚ‚ªzÍGEç•Ö¬õˆ²é$) Åì$P‹*Wtöåc)²> ˜€3SþÿêñNõ˜+|é•%„gòyµc·#”ýB…c}JáXÿ/ŽõA„o䃚€1çÀÖ£Ê1ÊGŠÙI39 u¥HG¡..ò?±Ù?ÅÄž×rŒJ¢À­Ý£æôðjºÇoͦ_’]ëÁ•¹MÙK&¼‹n Tô pë> stream xÚ­[ë“Û¶ÿî¿BMÚ©®ãÃO™É—<œq¦‰]ÛéL’”Ä;±–H…¤l«}w±àS”t¯wAp±X,v»€¢ÙÝ,šýô"•ß}xqóJ‰™eÎ5ûp;ãÚ0)ÍÌX͸䳫Ùoóß…0W|ø¹ýîæ•t½SFà ßùõíÕµ4nþúû_?üó÷HGœÃŽßß¼ÒQï31Ã]óÝ·Ôc@˜GLÅmþ(;7¯×iµ8šg9•¬VYá©.è-ô ¯Å×óOø/¥wUÔYUgË*tÙTE¨Ú)¼Ý&u q[”#¢iYú6¨ÀûìÚp9;»¶vÄ´ï/4ŸWÅfO<âSÊw¯}õæ'“C)½¤Ö$_QeYäÍÌð1ßoiYуg +í›,O“ÐXª:ÝžŒG~MÚÁýhÈx¯3o:Gó¤LCÅ keZïË<]1·ÌH(3Zt*!">ߥ%0½MòeJ YE岄I.“ NŸó#Õñ}ªu±ß¬¨¾ßWiM\r,#¥“툋¢^ßslz"É#éNA&„Cbà&ÿç4%]!ë" º‰oŽ'í$ ¾$hPñ“€RøIÄ4‰ JÇ;Iˆ˜i«Ïm¥˜qcû;)pKCeÆj’'›Cå¥OMI{§<ÐÓ²¨êÍÖ[HÅb-‡òAnëÃåº9šTÙ]žýEb™äuÓ¸-} $}½^'yS ¯a÷4Ûwë¤ Õ¬®ÒÍ- †Ñ´Ážq¬ öÝPç°)…aNIbO³ø ø¢ù›}}]Ü^/aöÜ6Ô‘û@«/e'™Š:;׬Šݪ ÇV–©ÎÀu½ ;…3+TbKL?ø‰Çn¾J—YE &Ó&l4ßWáuÝö˪½>PV5 ·íßA+³/ÔXÜRy{Åa;/¡wE Y(ÁøÔe±Ù¤+úxqN bþô¬DoÐ<¼C·0—0–EæœÀN9”¡àš};“{ýèOúÓ•Ð`‰ö)©¢ä†)«†ªXŒUi šFµ¼X5JTM(i§Ogh 3žQ‚áTbfyÜL%ˆ´±”å¨éMÑjcOß¼ù¾³¿ÝbeÿKÇ5£·OØ@¾œM…àf£9)M<¾õ{ëx&~#Éf&ßÀ¢xV–iU¥aôÅ᤬Wû2ËïF¯OÌÆïî{N€˜¸›·W ¬EUe‹MçSRf ÞýHë(;†Ð¦ ª à`’ß7ÓdÅäÞµ20 •¾Ç†GâL¹ŠlðnÄv·IëðÔz'¨{ïåÐ;Ù€H`üÏ€Ûê4ŒJ~Q’D_à½p| Jª4½ á0_Ùûý¢J—Ä%„C#¹ÌeyJë&@ñém·\Ÿ'vìu_ۼͺuÏ&´¨[‘#7{Š½0Ì€¿wé6)?NmÉ™ŒûŽ@9CK*•>9ØÛÚKÇxÌÏL­Àfˆ™Ðd >}‚ÁÄl‰’’âÞS3©Åã ¦ësÞ'H¡·|†)J ¬Ã)NØÌóS,ýÂJÄœ+ªù–:ƒàtI!2¶®Ce••)já›øL¯ñ.à8>F­Þ•)¯/ä UµÃý‡ÚDvdæñpeÔÜ÷ÐóÏë´ ßz†xÔ@^ÉyG·g@Ðú8îUèývk‹ð…ÈFr[§e¡!—å.&›ÖæyÖÄ4›@☙9kÑÿüæ»sëıªº xÑóëmbÝÛb¬,ÒÛ ÓÌDOpl¡VÎ> yß Æ;þÅKõRÓÀ>±¥! n0^~ΪôåTh0ªCÙ¿üû—·ï§¬æÚ?g› ³o&Œ²9&Žk k:RÜ›z»›C²¸ ´{[¡—×Á4Ê"«Ë¤iGÅß„$Nžl½Ÿ”\Ì-ê)†¸$dÜ=¦ËU+”€ÔCòÈ;Ì.w=Ål[Ç”:kÒ”ÆDØÚȲX?* ŽØ%­sãG[m°cð‚R{“Såð©²3éb;ý„©rc˜–DI;soë >œ·AwAA³é`¦Yu3€Áû€Á´ùü}Ú™àÒ§ÉL£°Ùç+4“Âh15õ·€i-´Îê5ùXRŽx"mjmCÈÆ­ƒ vÊÀAó²LÁ­¨•p`Üæ>°i:Žè²’^ú]G`Œžø”)C¯÷yöç>Ù¬©5èÑØë‚]Ž"{Ý©âV%³*¤0TÌ”ÕCadƒ.׉OSÝ…=ë12”qfiºëì2YŽú€¶¬õQ¢#zù¸¸·¦ð„@á¹nz ñ84ÅÚ"tY¥éWôÝR™P‘{mú<¦•ooÐáú%eð‰IˆR«-pÎÛ,§¯&œo/Gø?¬™Qóc×¢K×4y%̃¶r@c±•Ã Ë[úk¥QÒIý]žõëŽMK?¬ájb™,rLfoðÉ 1ìž“ÝnƒH­í€üàÚk¯ûåø%å• g§z™ÍÈŸF i­¾$×…i$þ9ÅÜüë³.é«-àr-«¾uWèÅèÁ[_K¨kåǾۦyÝ£ØFƈ¥×'y)mH@ãÇwiŽö Ì¥ÑÍÛ@wŠÉ¾ÂÙ¾ÍrQDz´Ù²Œoåb_ÓCB°75€õšpöÕ…ßÃœèHt؆ŒëøSe ðÒ4e5É=×÷(’=éõÙ“æ„Éav¶'JNÃÈ#猌O(¨ùëš’”àÍ1 ´óÏä•¿Òzò`y•-2 ,²úúÔè·4¶xbbÝ< _W벜zg¡\þt9É[N¨¡·/BßtC4Há&,Xˆp„n¼Øx+ã¯>ÈÁÔnæ‘Xîº#"×sEž0RMöùrMÙ];¿-‹-ÕâeAžªe™íêÀaú§”[ÍÊ"Ç-Io‡8“¨•!Ï!òÔÚ …°o³Ëu8p\y§£d2Â1_ûÍ„\F)¯¯ÿr³Èò?Ÿ‰uH¿ìŠø7 Þ­ Gy 'L æ åž’—àʧ®’Vç ¦˜ PÏ1&€F)ÔpLBÕß~u³)@Çn¶ûí®šÈV(½À> ©4¸Q;db•ÔÉÍWˆ™‹ãǯ‚øïY–é{­Ì“Gl¦7"…ß~õßb1u  Xô;Ãb9w{Û3•®R‘=ƒt¥0ÌŽ¤Û¬|옱fèn·»¬Üç´ò×ùŽ*\Xª°Ïok+'¶õ×Ôóý~¡zèN‡|Õ¬ÜfÞVa5 $Ã,ÉŠ* #œ:q¢ØcªÜ’»¸ý¯á¸_ 0š?eöúv‚(Ä€Ñq:äx[ ¸Á™ãÚÃnÀ×°¿<¡pð¹ma˜ò9†”ÖSŒÙ¥Fò’è[ÿvwI^7S2ŽcsIäö‚È1µkyHùû]âvÏ1¤& †ìòc™Ëþ!ÁÝ%ýãÄ9Åðª„ÐvŠžWŸpL\ÇŒÇàN¢´Ó>lâC´ £ZC”"ÓD—Iù·‰IaN–Ÿ?å ¥~_ÃM L¼ ØêïaÄæ˜T¶±U5&„B¶XJ0iÝHEyph€ÈÅ_›ËV>ñoô†‚3h@PMMH±Òd¹nI`ðS”Í0Šrõ8]…ëf¯F.~D:TÜÃ~'šà¿ …¦?BÏÕd>„"qˆ9|$Nµ¬)+*éòwf¾kOý•=É5¤B¥7j/‹ýÝšŽð26ð²¿&ðb؃b;qf/h¥2šPG$Ÿ”¢5Ì-Q’÷¿‰5gÜŽÖžîŸ  úJþqý‹ 'ËÚ-qÎòc®Vò&z„Êq,ÇGD}p¬ X„¹‰èk$øOÅ ÄÔü¨&ŒãaNÜ8¢$•9·ØÀfÑŸaLhÃ1O!ØgÝ/#)Ò5GXâ4Ã#ž‡fæÁàu»ûgæ¹VL˜|zf)IÐØGݵɋrJgL;y ¹)¼Í©7“Ápˆµ­VÙLc7ØQlÈ3Œ PxwJzLJѼ»€Õ^?˜ÝÞ»íû„ÎÔNåEœÏ4D—Ïòø0/ø¾®Óí®îã³Ðq¡ˆF·€. þÙIõ ()ÅR?Jy_S(eÀV5ŽWÛh~ ¥­¥`…\¹¡ÿæ@eÐP 65(ë„R‰>JñßÍ«öЩ£¨<Þ€ÌÎÈúL‘!Ô$ýÏ0"ÔÀZÖ”pZ ¶tPÄ<¥oíC Ó$<±ÒB êÖ̃úØ#¹6ì1‚ÑóCAGë{þ˜˜Ç1è’„Ý åS.¾p‹÷ðˆP{¥úòÑ©î»8®€-A¬ôm¤>…=Ã*~ñü¯Í3F8ŽGXñK‰•£%ÂÆ èã7žV#Ý<áQ0Á‚—¡€uëñÆ[ÎâØŠÓ7íO“BÿôE$aÚÁˆ§í ŽmÿbyìèKP> €(ˆs£K—|aŽV?jªGI9ëS=sËÄúìÐýèðTö”Äã~ò’I šéÜe%Q Âø ‚'¨"ü‘Š¾§’€ÛÕðþ›ÿ%F·ýç§v?žjùøgzßMÝÑá(Šö^o dºÛAQ{OqȾ.¶I~ccôœk,˜¦9FD0ì1kC UÖ²ÿ?‹ˆ‹º endstream endobj 1656 0 obj << /Length 3086 /Filter /FlateDecode >> stream xÚíZKs䶾ëWÌ%Uœ* –HÜ[œØ[›ÊÚŽW)(¤a-g8&9»+ÿút£| ¥Õh]•T*iðhF?>4®îWáêÍUÈ¿ßÜ\½ú.R+)EÇjus·’**Ö+“ÆBj¹ºÙ®~ b‘®72 Ãàçuuó¡=æ…]o”N‚cÞä{ÛÙ¦¥ú¿Â8\ÿzó7˜9\¥"3&rÇR¤1,ëf|û—ïoþŽ”2‚ÿ’éÕˆ>E LŸ¶Ks'ÉÙœJOæí.JE$S?ÀQ9žqzW8µ¶¡Ò§µ a§kðfÝt:-¿Q&:MV™ˆP²°nv ˜Hë`o÷uó@åÆþv*»ÅZt5·žTèü˜Ãio›²È+ªwyk[„;»C¦ò¢«›ò÷¼+kîØÇB[W×2,m ›Ê–~mÛ•û¼ó,lO¸µòpÏíÜA2pÎ ®Ì‹=¯Ú²ëM+»­é4 ÚòwWÒA}G-ÝŽXn^C°>åUõ@ƒ(°ø(ä«£ý#íÂ~Ý {´‡m˶0žÄPì@] ÐÖäQ´Ôè6á ¨¦ü| •8"éj0º³½«K-níñÀÙjÇr­âàãZH:'l¢Î;¿Î*›ûEjj±xŽŸ»&_ÚT Éï-0)Üâü'œ25A^µ8Cš°`@¹«{_·Û—‘Œ- ÚS±ãÁܧ™€‚l Øí«úÔmê;W&Ê8ë÷¥åQÞòÁ¿„BÂ_¼jÐÑøÊOo®f¬•‰NÏ-Xy î}ÕÌöÎ-ùÚ j£X.6Sy Ë6©MVùg¯UxX^,T½|7R%"J¢'|ÜówC<°êÌ[7³²l˶țÇhëf¤Õ…e¥GË4’løúLM¥·`…*_ ðéÄ–¹|´¼\>‚ø…(0e÷f†ì†À>²ö]¢£ÌÒÞ9åM“?´Ô›£J»BUÕ{H -  ô[¯×›4Œ‚·ï™îÀ\Ç- ±3ÔžQZ–W¯Šz¬È¢Y›8`í•$4ÝNcÛ£-:ö$èÜ«Òw0~åIš»ºÚRi8°–©òÉLÕÔ‡Ž¿ÊÏ€AÕ#xBèm‡iïÀwœ‰4’~äëÙfâñ"ia`4DE~S2yJ™ˆÓ^£jzü«1JÐï;2ä5œ÷7ÅØԩؾ¬*V h!¨ ‰| ÏúfŽÝè>É5ë!Vp´†ÕZC#!k¨ Æz&o5ËæöœN558ü¶¾P§b¸ š²}ÿÝN¥â3•zì4LÁä+£wvûüs¹?íÙóXýZßBï"ž÷¯U5Û{ûúBŒ°Œd¼ý7nÿæK&àǘÙ}ö’uÁ’³óe“Ë  %Lñ¤©4*Ñ_{hÛNFá@û¢{ ¦Q¶NQ“ûþÒóƒ•ÍÕ7ý’u"LÜCäb|{wéâ"¾xåH %{ÅÁŒ¢8 þf|Œ×}>Ù‡M•¤" £Ùýþ¶­«SÇæ4 W°Ô êIínÚÎ…×ä‡ÍdOa*tÔ+XïíÎ=¶–Bö—#\Î[-‚NËˬÝúÐR|4)¹÷ IóÍ@)¢ÐL5ö TÃuøyÁ nUh=Ï VÙÂDþ?X=¬\õB«7˜L< YɳCæTö?²Ô&d©ä¢e_ª”ˆeüÕ¡ nÍl9Š3„J]ª”&¶–Á4Z)}­`ÔÅÑ ‡Õ\sUøÅ ¡E8äÕ \Å*Åpå¸xõª¦í¨ro¶ÉÙJó#Ø)z-<œoo®~»Â;J¸’pOEê•ŽacZ®ŠýÕ/¿†«-t‚߃%ÓÕ'GºwÁ‡U«÷Wÿ Wš‰<”-ÕJX< ]»²”ÑÈ·Ë–ŸhÈûLž7ºš~ëršÒÅ#b3½üº—žÉ[|q²HŸ, 8‚mÅÙT?Ü ´ReDmd&i<ˆI,¹Ê]Ëõ«ý ¥.3<Ï4 µ³Á£$^?ÃðMh@Ýñ¤XäRoªàÖùÉÏW3S£ÌVÏòù‹éL$(#]R¿¥¢7üY}WòøÊD”‚ÖccÝ2e}rÃUPP ‰–ÞÁ´ÈT~÷Ïw?¾_0#• 5\™>)]XVîT¡ÞK+ÎÜà—9®òâñÔw Ç*aªQB^fZH3K)âp¸µmÑ”·vn£Öƒ²IR‰Òb®>O‹9O½˜›©¥âx¡Ûê‚Û€µìV<[¤ÚÁœ¼ ²ÜSÆbœx^L°¯·åÝ5vžnÉÞœú›ÌrF£gž5¸…ëËŠ"à;ýê§ wßL½®“ä| |y°[Ž! #a8´A›I¥?¬pLÂÖÁþ±ùSÙí¨ñUhŠÑ¨©Oƒž£mùïöBïРìýØ5ù)§œ©æbKÙRg öé³ð<Õë±ß<Žñ«ô²æŽ Ídz;Vø‘Ïr¸‘|íS‰tô倉Ԛ’í.¾D¬Öý;æ±*‹²£PNÔ?W©ÑÛR`ÖžZo¹¥'a|Èé¡ …$ŽC>)ªÆÊŒzâ+‚'pj,åâã#<ê½E*@Þ.k2Rë3Å·§ù…ÔÛLxÀ’{gèß©÷ȱÔøe¯FÀ,Ó¤Sïõ3¾•Ùþ‚áÃûŒÃ­EÀs(½Ý›½ Ɇ ŠT¿À¡ü¡—‹wXöÖ²ä_/¤,‰(RN²F¥O|á2õ” €¸þZ¶™§§®ªxKºÐbì´Ó\ÇäbîB&zñÈõw‚Ó\¤™{†øýÝÊÈ"“£TÇF»·H¼ºzVnf¬îj¥oën÷„kÞ¡&.tÀ Ë/Õô ô̽ÿgøW{—Ÿ*fñ£¿úœ¾ØÈÙÆU8¼•Ú•>›ñèaóýÂûÓô¤û‡ï/î‚™™ìâ'À½:ñÁ àtéÞ•„BÅgo,Ï}'*y–WýÒ^À?ÇJÏ÷²Ï!0.ßõ8Õ¶‰#üLwZcD%z3Pø\g’1&G 쬪»Þ,Øì ñ–ʨÀØ7~w„æùíàšRÔ|z”²Ï¡‚ØžD ÷u³[Å¢çAe—®”0¡yâ3¸¹¦fjÙñh©èå^úë¿TCÎJKz°ÙåDÆtÓÜô_Û@ÙÉ~ǹǵ 8ý(ùC†ó»Já:>ä¿Ÿ¸Û˜¬O®#ú ±Â 9Óé,ëÍ ¿ ˆÐ­RaÊ~¨G9Çcè&JTð¶#âbœ©k‰Þ]Ò°søšÀ×zè‡ ôqúQÉ}K3Ï!¹±ôK2vëÎ(< àìzmšÝH'8òYþÃëÕ‹~„~¥wø¯Ö$ Þ…b‡ïdÖQ wiÄ2áÿ.0äüÛ˜léË@èwžžg>ðê΂á·>TÌÇÜ ¸NŸÍb÷¿ôA²-ÎAC†øÑÐE<I¦ù‰D²àôH{sõo[± ¾ endstream endobj 1589 0 obj << /Type /ObjStm /N 100 /First 989 /Length 2541 /Filter /FlateDecode >> stream xÚ½ZMo7½ëWð˜\8dUñkaˆm8É"k ¶»ëøàÈ“@X¯&eÀûï÷=NSòØÒLÇi $HÕÝÕd±XõøŠì˜’ºàbJæ¢ ÉIéw²³P)—,Q¨.WÕÕÈG–]Mw̵`’kÖN d×ßÊP )A3Tv¢*%<ˆ…m´,Â6 Hî÷hUì÷Д¦~/»hAÑ…¡)³Þ¥FÓzS} …vUöQÑ[–~‰Þ2MG‘0©”LK+ÔÈ{jÊ'1‡ì$äî˜æD…ãhÁ‰Á=¢“ÔûÅ)½¦NjîOÍiˆýä0 ¶Ò²SaG©§&tU«NÓöæ´š‹?ZµKÑiãÓÄY JI‰õ§æLKZ¥˜(5H´/c0†×0˜aÙªZ†es`eÛF‚T©¯h­Áè›K’„RrI9k9f—=#B"o{¨ž¦§bs;ŸÂ­ðŸB÷’¸¬ÂöD]¶Äö0Ù¹{/K‚=Ò§)#ƬQ*.·Úß­®ÄOq‹0T³fWh¦ÄƒFE×ÅJV\I½5śݳÁVrd_ðR”Ü[CèoD´Eô€UDY›«ÆØËpRM‰#C×Ü}aЫ¹0$Ccdfc´~Y@OCBhî÷Šk)ôih¤æZ)ݪ€t 7;‚U|Lÿ‡Xûs4”I—é»`ÌS¶¬uUfY²®Ê4Kµžõ†/‹XÐ+@J,úÈl©ÅZnµâìüjíß\¾}û·Ú–s‡…â#±ÒÄgDòÉ'%†‰/QöÎK\t^rñ…kô…X«Œ]¸¦$=b€´ì‰4øWaYöĵp]ÿ”Ý+,lý¹[ýó_ÿF^zÅ Àìâûw¯ïTŒ1y Tn‚dIK*KEþ~süÛ!;Ä*â€[“ÀõýÚ†ÔªÀ\Ñ}pŒ†Ø‡9G/%ϤâÀm¿²B+a~{ÍýW«béð‚µÜ+ø@Žê œ‡œ}ýÀÊëgÎ"H ÂýÐÍ@-(#YÛ̆ '¦%•G,¥€ù>hLj%kÑ+|–!† VáyómÀm6o¾1}Þ°¬Ï³€ qHM–HmÌ·|¦ýdsqÕ‘ã €ßâôÚÈÜé¡Òt’Ád,Ž >pÇí…‘½Ùt‚I :=‹×‘Ö4] ÐûÓ^*ÃpÒ°©Wº²ív¯N/7g/Ö@E·:}üÄ­^®?^¹×»@{úæ÷õÉꆷ¾¸zOØ#ž¾ß|¸<[¿ß2Ã~ïë·çon>ºÁäQ¥q•9}s‰· iz¹Ã÷{tÜù2íétyâd:BBBBÂÔ2Iò$Ä!ÈtÛ–_/´Ì V]_Û°^‘M;Œ‹Ý¾ðn—Ytµ„°W¬²† 0дÊ ×9ß¾Ú=}òì¬viI;°ÔûˆÒ Ú3ì#–ß„yÆšRïsùߥf–«¬JàÔM¬g|Ãò„LA<"3+ª²<2íKO)4Ìv·Èû¿òïŸo.¼âG–œ",:¬Í’ݬOìB ïQh)2T,±FÅÌ°è#S˽õÁâ1 QÄlfÙìQD£†0,¤ŒäÔzü"ßH@_-[v¢š1c…õ?îÛ=fPû²L^ `V,ªÁ}Añ÷ÖzmI+À`0?X:Á8 ú­>WØ:VÃíôôù/´ oÙÜ°@#"£ì5`r„Ê} +ç¥ïLèæIö¦Œ,†uE¸y3’à î¨Ì0dÙå¾ ]LAîr¦¸ë´Ü-F¯g³&EhôK`YÍwBÈ ~|^prŸqVÁ¹£Ñ-5_žO3µk¼½L¸]+«ÔÙ–DØj !ì ÅE yãÞaŸðÝÏhñ—Þ¡Ü;„YùdleC­ï^·8ææòtÁ=Ñú%ƒÿjÊ­éKÊ­úÕ”;Ocí{¶“‡P†P‡0X´ -ƒEË`Ñ2X´Œ–e´,£e-ËhYÚ¢”Ôš;Ç©4 2æͨ SÁ1÷bà¢`, p$”‚L‡ë¹©(D éí óÙæìåÿx{~¹ ñy©¨¬¯ÍhÜM‡Ì8½\ÿvþqI¦¾è'íŽÏoÌëTzÙp@QG¢Q[i.7̵BôØá¹Ac7á€U`QfF>D"I@¨$ªï'‡QPúʱ¢R À„†å°Iy¬Æ£šä²ùFtZ©6“7ªxÃVyjUiOl5%¦Ai—ê ¦ÑGÈm¦6+ž£ÝÁ„wˆì.-¾“üîl1B~¿š­¦ü%[M6­æ¾`«:x§Þ©ƒwêà¦6tlèØбÁMmpSÜÔ7µÁMmpS-§Ñr-§ÑrÒ%ù«q®q<–ŸZ Š7= xŠ‘Á¦ívx>¢K3P šôÍ[mioo‹VϤÒü2$pc©o4E~)Nkº·ˆ×ew¢†0J :Kb5"$»ˆÏ!ÜY¢! Š<î•¢"M<½Îrç~þÒÛùŒžÒè=@I“bõÞžýµX÷+äe¿*‡¶a¿)¨,ÿg˜Q–ýèîçG õ®æÜ7h ëW+¶gZê¢fTñ-˵<°g©d3$°ÎJIß;š­Áenûb´ÜKŒ"y¹¤@¹ƒÓNÑ!÷¤“×Q:ÃŽ…£4öo²´òÐ]z”¦P·G“w|•´Yø î€ã‡æKP~ÓØî,€ïM™ü–U ò$1O1ܤ@•°÷ÈKtÑŒaµÓÿñ8AX ~1j€•r<‡(B2è!Š2ÀÒ;öÇؽ¯$¹O¿*ä9‹–?eH'Ò)ÍäþŸ*Þ3ßÑž¸¿(?x¬3µQâî²ùÿF¿ endstream endobj 1699 0 obj << /Length 3991 /Filter /FlateDecode >> stream xÚ­[Yã6~Ÿ_á—ÜÀXÃ[T»@ÎÅìNŽÍL`“<¨mu·ÛêHr&_¿_±¨Ë–gÚÝy±¨"EVë&-· ±ø× qæùÙ»¯¾rbá“Ì9³xw³&Md*ÎÛDj¹x·Yü´üîÊ‹eÕ4åõ¶¸Z)+–¿çÛCÑ\ýòî߯¾ÒÙè{›&ÂIL>ü„Fô«-VV%N/VÒ$™1Ή]þG¹;ìxDSþI¸˜lYÝ!×Qߣ½+vUýÀí2ÿuq%íòöÊ.óÏzÒï‹úÌGÌo«ÈÖbÊÿÍñ3ùZ™Ä@¬&"ðEq“¶íH²fXe|bÇ‚µÒÀR¯‰#ù®hÁÌ;'Ù©H”=‘l‘”ØEMKw/ßfŒƒMTªºo_þÍ»7? +¤Á¯œ¥á-©M¬ÒÇ´ìrü ÎZ&:Õ#¦9é—¯!4FØ ¨’Ò“‡hãi–·u‘?ÂK{—ï¹%:@±çÍÔ~8 æº%¿þáëïÞÎ!6©ž™ù¡­ „å¢ôÀÓGElúŸÁ¢OXV7Cæ_¬”ð‰7àŒ€Îyž¸Üƒè+¶9S½`çu?4 kÁÄ  Û®E’ÉeÓVu~[0ô&È?@rŽðÔ$©Ê>F¸Ê+{öLñÛämέ2bWüvè:ƒÖáyºk ¡ÝòÝÀ“(c#'2^©†¼ÿWûËWûDCÎ!¹ÇŽ‹ ÛJ¥éòg!TÝŸS¿Ìïï·eÐAôúdæ0â À%È ®`¨›ì'ôúmœz4-äiwØCÂZš‰¹°Xù œÊ¦œâO 8ýê[n\_)±<Ü\)»¼)êæï2IÝ5ԯܳµÄkN£§Áy¹ÍÙcÈRôG&î.ž·%úh*ö èbt?9MÍ-b{Û® LDk]—AqXé[¨íöéÏ6°ë@ª˜90W«Fj•.ßrÏ]µÝÊè% EŸ¯¡ xM†4m¾þ•;IS ´®öm]23ƒ è5œÇ¯ dؽü”aÛŠóžö™&¸®Ýü˜k†š^,;3¦œ ü*o.4Óžâ‰ÒîEoàïò†qØW´KÎÂW†hWmJÒ‚ ÷xoÊ} 4yÓ1º 1bÊ8á±Ètýp2“‰|Ñ7_}û¯@£{½ÍfÖ.VcæÓé†Jd6–”òO¶>gê.÷«uUDZÁ¨]DJ–&ÎÚ“íRêc¤ "0²·Õÿ4þ%Ø)2eBçR¾•H‘ðU=†¯2KG| ËGfó,ô= «C»ªn˜lþÉdûé~\ÎZ®Þ=•³¾ç¬dC;Å1³ XDwªÁÚp BÛâ¦å™ÇÐÓÆ®MÁì á#ØðRvp("⧯„9« Ø(°¥Wd[2¤¿é°uCÿéžÌX¥{˜¯1?ŽrÅÜD˯‚Æ(7¡×!7¡·.7}á†Ü$€Ÿ°ë©L„2c!¶!ý趻D a‡R„B‡J¥iI â‘xv„b,¢®à/²è©ÑPâ£3°ŽìŒŸY³-kîÍæ¡Ñïf´›»ÔH§(ÐS<€L2¥'€€ì¨5ö<öD`·/£*#Ê—!s1+£VË-%-ž£!­/'öÊIý4Jv÷aé@-p%ˆ> ÑäÏ­Y~S…MÕª‰°­MN;YGx¾^j–"lßM Ââbß–ù–Ù”™D3å»Èºá8qGÇÑm–xûñ˜Ý%>ëG½äùbC/,ªXï»Öy\óºàg¹gŠ ´mâg4)ŠrPHr±å ×`"-äÈ Üë’3#êŠÖhôé‰ p.I­?Ë„c)$ uÙh!eÓXp=&ü¾`p]P ]„ÔºXpËCûOƒ0ëb0mƒ© Ê[nâpÊt¬íìõ!B›òv” Ý-(È(Ü.Þ¾ø/×5§: Ô¥I1W–ˆLŽ³RÝ¥þ¡Upb]sk$¹ÍÑ “L+@OÒR >6m‘oø%íRƒ%8gÏØçeÌ=ÃsdØbB(gW—§«ô6áç»°Šì‰“jnôîRK´®ãð‰ÆIÍwY\aÓžÿ8®ð“FØgëzo2º^A€ÈIÖÍ×™Áh{{â:/SsDCC-«ÃZ‰GDCNÚ1ÚÑsQ}LAŒŽF“åü¸¯‚XDXÌÑÑŒ>I@ÑDh5íÍNÂN€x“©u}vȇ#Ñ'N××}½lmyT†žXu}ï|‡Âgú´^=ˇ͗s“¢Õ½o÷àû&š$é4,šRú#pDl¡çëºìªÛ×E¬F‘Ø2Wû2ãŠ9œ |v_`îJæ×nû5m{N¦ï“Ù0[Ïlj=áÖî›SiéØÆ/4 ¡EþõS‰°/û€¡”1‘ã™´ì!¯ÿÃ'5‹æF¿¹ÊÔòÇÿœ"§„H bã'!7YP ìÔSä~xûå÷óQ›ËìÔvôĘ!`C†"å’¾-ƒ‚áE)'‰"}s©rt>Iaw°.îÛ®"`gäŒûÖH¥îB)Qã“KÉ¢èY§Pe†Š %B/_·Œï‚¥È”„ÌÐ<öF\©Œö¯Üs¹•úB¶8³?슺Œ›i8 oú±§9€Rhk{Yð„¯Ûˆ÷¸ó\™x)cðÁ,ÊXÔ“é’˜¡`Š?mÎ6#ril†1é˜\‚3¹d•µ¤ÉàÎñ#Ð.Ú¸ú›+Ä"sjk„G. e#wö ‹bˆŠç1BŽ”–‘«œ_÷ÕþÏ¢Ž°a,È0Ý©U'‚L>É»ó”HoaIíBGEx†uô>‘–g2FMhñ]‰ZÁ}x*PQ6³o]†â]w„‹VØPÞÛÓ {ûËŒ‰P½<ÏñC#=0iú4~©p„}ʘ%«FšD„¾ŽlØgÓí¨ÖMÙåê¼°¦TgÁƒ1H²y’ ØttiŽ’ëpdj‚ Óct~A¯ñüÂϧ–ñ¦ ê{Ýë: :')â”íÓsÑB¼Ðœ™§—š€ÆåR£ Ø£ÙYÓÑ.ø¢Lâ¼z†Ð“%a`"ãõ#e†Î½{_ÓTùy˶zzýBæ „LÓƒ½ëxDn§¾™¼‡ sÇÕ‰õfˆsΚ*×C˜3ÅœÏ13.¦h&«Ìqœc§þ AØ8G’qšÜ?pC~e-…i–.¿†ŒN ·FtÔ°ËÃ7£h:LqÓšPps´!çm¶Kª…J=,î³l6tTZž‰N¥Ç¡!]Äëõš/Œ.ÐM®xûžï P¡àôø—o!ÆÁÍá:ž‡Ä÷j{†± ˆV„Œ‘—§FÄØî†Ø;2"ƒ 5®fQÏ ‰µ‰îó=ó„ù%e“6ÂodH»óF‚Ž¤±éÊÁÇ ý#aáú Ï”Š±O`îVŒXWlÓ¡TªÏ -ÝSŒrNû„r¥F°äG¹i(ô1œ›÷ÇÃQ4“M3÷ÆêbsXÇî8Îu•^ù K~ e3ˆà,²reù¢ã3¶.K)ž)5½Ô!ÇŽÊÖá˪‚PNØ£ÒûUŒçü­ìË„PG6a£±É™r_¨ó¥Ó»©÷):Îx^Fë}Tñ]ºó¨z߬9Íl¢> ¯éZY ΧS¼Î—úÒiÙWC‘r~œ“t¨©Ë¡¦.}W5G+ t{+þ ½’KíÓê:}1ª›3„/-Vˆ%ìLƒ+|A™ØBô¹6¦¸LDÝÕ>«I• o<÷‰W¦z¾{ÄuT?”åÞÇ;½¤*у;3[lИ@ÿ =âYy#VJ´¥™ÒÄ?:q¤ çfz/Cuò¨bÉÈÇðŒûá:ãF *2žûj¿ Eªp€@éÏ”úB¥0ç&ýQ£UÑœžîœCrìsXº>èŠu';Ü>…H–›nÉ‚ûF7jŽwœâuØâ¿t ˆ‡VÍ6ÚÓãC|ò6ÞÉ€Öj9w³ÖŠî΀8cBTˆÜeæ@â³"²Ì„ÈŒRæN"²x(ƒ#“Æ0~ñõEG¼m²³ì6àá>vrMvž™M‘0I¯‘УR^žá‹lœ‹>¿T »„f]u‰òiˆiô³âym=U½ÂLR色añ^ÙÐæt|»Ž¬š¤s™î#Ìè,£ ÷¨ÀrÈñfrºñÉúÉñ9q^]z¢u²#†ªPø£?”¨pÑ.Ógí'`þÅ¹Ä endstream endobj 1736 0 obj << /Length 3195 /Filter /FlateDecode >> stream xÚÕZ[oÛF~÷¯ÐË21sáð i»)Ò Ünã],ô–èˆXŠTI*®÷×ï9sΚ’-7-Ð{FùžëwÎŒX|^ˆÅ÷‚Ëo®/^¾ ÕBÊ 5F-®oR™@½ˆH-×›ÅÇ¥ ÒË•B,¯ey¹RF,÷Å¥Ë/ø¯î¨©¹”ɲƖ;jØä]¾îŠººüåú‡—ouºH‚4ŠB\H,V2„ä%ÞÁ¡Ë¢…R¥Ë}ݶÅM™SkWSIRÊn[a+ÊÀVn¥åž‡¦¨>óèmNCnqoÙº«›â™Ý—ý~sOe›w‚͉D áÏ,¤•ûñó÷H11:‡ŠtÊúÐ9¾½º~ÿI¡Bø/y."÷Ë·f<2L``⾞¡ðE(×A—«$L—ofMÇÚÁ‹•V*HŒ àkJÃ×uÕ›¼É7Ä›¬¥²ê9ZÜrÉì,¸G»ËÊ2oèG·Í*žÀ54y»­Ëcù'!TåVÒžGM™ÒôDqÄÔ3´ô(¥Ó Ò ˆ* ƒH¤>ÞÀé´Q$Úèe^m¨¥¾õ¾¨9qÁ»Ãno)}ñ÷ë‹_/pU± •È@*µˆÂ(a/ëÝÅÇ_Äb€Óê4YÜÙ®»… ¢*åâÃÅ?I ½Ã¨D‰¤™€Ý÷>kþv-”©L{Á¼zûã÷V0“Ljid`â^¢ï ¤ˆP—L…žJÄñu‘WëKi–÷³ÄÔË¢*º"+™3* ÄTBwY׿]®ŒI—2Ř„ÆÛ–¦ÉÎ&0aqdÜ9~z÷﫽Ÿá[ÔÖfi„` Ïâ›/¼À/£h&˜•–}ÿîÃõ)b+ öÀ%d|uÞ1Aô#ù 6[û3^Y¥‰áH|fø‹ËU¤£%Ê¿Ç’mÝvö›ÚšÍÒý(ªM±ÎÙ*)úË©UjÀ|ìkèˆÖÚ”Ú–|j¡|Cÿ¢7[ç©x¸$z¢^€S酢ȋÈ^{]œ2æ)X…~UÁ&JÆ*“Ä'Ê;´°R/ëfcÍ.T-Q ¼É©Ì¬kÙçÍmÝìð‡²¶ÚÚºü‚:É]Û.ß#Ñ”dâBÆL ~ÜÆyË6ù¾ÌÖÖ¸c+åÕ¶‡ÏÜ Âol1é þéºQTLð¢{Ðm­Šä²ÌºÎRêë¬Í©Fg€J^滼ê¸3Zïóº.»Ê~UËCµq3õ¦'‡¦¬áo€ ¸wM¥@)W¬C½¼î—ØÖ èãõÕ0½G øýWËÊCnO.& îU‡äXnêÊÖèe·=OÔ#tN©yÔ™ÆAdÒÁ™®Œ ­Pj+9ȬÝY÷xÏ?úMZo1:‰ªZSŸu½Û:näãIÖ;Yµ«Ñ `wr!ÐÖcB’"iŸ|nÜ¢É AIS@epV5´÷ ;Öeé™ €›rTxóŸ}‹h¢ôþ,`2Â~’oæ0°/ŒÆöÿLĤIô}šÇÐ'± ÃÓ+Iuo°È?X¢6TfT0éŽP›Œ ÖÈ !”bÎà&KòÈ¢F2@ÐAl&Ìõ&±Èìö ÝM4¦û<óâ NFX©Ä,ŇÂ@ëF¼8=!˜wýDöüQ¾†XG ¿­×EÖ9x>òµí#Þ6 eÂñ&WÒè@+(Ü*9MG ð¶Ç—2šºl'^ˆíÏšƒ“O G¶ÈA(:†GáÒј+Äij‘êˆÁâÝÌíZKe/4¯@jmˆ §…<þI&ñ™8(õ>ÏDöhnïŸö´9MA£iÿ— Ä…Ð8ß—¬)з/I£"e÷LrpÁ!|]‚#̈?¨¢–z8óYòH8VAp-ˆ8ôÂÀQ "~>×1C@ÙHäþAe"US|x;C1b@䯼µ+Ðlmßhr1éôàs´¼ªÁÙ:yA¼½é5õ°ÑQM Wlu"oe×sÛ–yÓ€!?9Ç1ø¡†WÎÃ¯Ï az[±ðô`*˜P^…(>œ¦aéó¤?ib€ìde^¶œX,Æö`cíóùGÐzN¤ô(µ'†& ´ËÒˆ'™2á¯ö]~›õ|ÿâçÃ(ÐŒ…ÕJ˜`c Ü­ê“~arô¢pLÇxYo¿?çåpr€ÖJír„þ°§9M‹£ù5LÓÓ3Mž0ÿ4ðL<þUˆÔOÊ$4êyÜ·)€ØÉTNvYóß9yÐ2Ðñs]ÕŠG“yPÏÈ@º…]æôÐNVúx`’Cu7ùºØä~r6{ øø¹[—z4§Äz&ŒLÍtZlrxŠ~Y+…•]½)0”ÂâoÜ3–yEñžmÛreíì"Ùx£ö° (û{\™†>ÊQ¡7¹Š£á 21ƒÈÄ>£¶Ë›b•å=5xñ!6PR¯VïÃ`œ¬aGÐœ›àN-¶8Û`–¯\–ÏÕ¹}¹T:¨ŠšèÌ1ÙoŠ­ &_'9§°o‰9“×ÄÑ’7ªqSY´Ü„ b9dá‡ËÚ“¤Ÿ§¦’¼ Ö¦—:&6VªíÔywhìƒ]°šì…7-{w&âs ¯Ê¸N‡QèðwV™@‡˜fŠ ÈüË¥ŒA3Â0bÍH£‘¾ªAÕ±z~f#ÑcôÃßœÚoC\öZsÈ ëÚ„î ăwuÃ{eóÌv˼`€_Ç6‰ô}Pú"‚ö$í,˜FèÿùPf š[úàèy×D±æà‡Â•¨Ã ª<Ñpï9M¿¬*Çlú”U¤Ý¾D#Ôqg³l¯;:ïÐlyñyÛ­¶YµYµîX‘¿ÉK0±˜Žáܲ-mB3È{›žÄ”î­÷ ³BÅç¢ÊJj&³ùóv)%ŒFÓ ù¿ñÜãÜþöSF—¤Üõ ¶´ž?IÖö^d¯ÍóóÄOƒnØòtêær"%±”âŒÒ9£JòiE#ç íÃ:{ÿæ§ËTAÌ1ú·ÿ ö\ð9ÛïË‚d8&ƒŸ²ÄJS×#4[@l÷Ãt²ž2—["ûÒ„aÞ@m›—{×Öm©FÔF¢ L\whM'÷GRÄÇ2ØœžÅ_Ž™è‚Ó†ZÖw7™‹·ø:5«Ö¹³ÞA%~–ØKXl².{5ÜÒØÔb¼"‘&$[´¹*ýH$,‰h"‘þùoHØ,9ƨEÕ‘ó†E!LÉ“…)_³BÅ"±ÐIAˆÏ¼v7’AÝr8tO¿°ö€ÃaÂbaÙ=úœûxÒ‡jJ,Và c2¾ÎÀKsλG¸kE">‹½2MÄ_¿8“LŸÁ“{Ÿ‹GÂH KêçíÍ[OEt¢ý½¹¨fêrå‡éAÁ°;â§?‘Y"(€vSìòªe®ô„A8\è^”^ØþÄ Â>ì-¥ŽIX±ÁÉÖ .À×9¸ß9²]kêÙrwž2UAûöÍÏ踚ÒHÏ6ÃÂünòÊ/+[žÁ¿Îš½³?,qwUÃáè9)]NÙTt'ÂÏI…Ð{ÒïŠv5g阽ËF÷¼jM“ó©wmZ÷Žþnf^<=Hð=€Pì…àø}ª{0¾ÝåTÇ(-U™‘¶AeC5ë\°B%ì‹É܇r㎎?èP´æÁ75úC¬ òÄ«õR'g°)¾Ö1ÄãEë¶É;¿á Ú%3ÐåÐz|>/V ƒ$>ÁˆS^"š\÷éNý³œ½{†hÊ>˜»z‹À‰«g«SàÁYÌå®·ÓKÙv‚nÜý4±ï¤šÌpçì éøO¿Î Š¿ïcçA·¿ÚEô3®MmWÌZ©ˆÍ`¡lÊoìzCÀ·ýþ©p– endstream endobj 1775 0 obj << /Length 3188 /Filter /FlateDecode >> stream xÚµZKsã6¾çWèH׎¼ÙÊa“ͤ&•WÍ8§ìh™±F">fâýõÛH‚‚Ç–²{°EâÙÝèÇ× ²Íû Û|ÿ[ý~sûÅ—¯¥Ù©ÑZmn÷žñT3±ÑE–rÉ7·÷›ßv³K¾ºù÷íÓÜÍïÛ,ÓÉp¨n¶JódÃYR멡ì\Ïì©z»»ºyOÏ‘ÉõÊ¡nj~8”½QÝð,ùs7-S7«%vÓÐv¿êjÇaÛî·»(6\¥Ü˜Í–³Ôd†xŒQ ÝZR$cÓ?žNÕÐÕ;ê8•ø\õÔýéP¹ ´)4íÛî“]³»§žêXŸêfZ[$uOUƒO•ç„„²gi*KþÅ2掆¥þ²M‡gä_Þ~§¬Øâ”3–*.aˆ]öÍ·?ßþˆ‹HÿypÊ+õ€‰Zøy_ãö:á8)½ÙJV$ojȇÇò 󤯛]E­õ@ã>ÕÇ#µ4­kºsCÆ‚-^c°ÕŠûöøU½¢¦Ü€Œ_Y¹Ôxʤ Ňs¡÷Ë×™Zj¼e(@r‘´Ž^ÎßvªÊÔa?é<¨Ýil?Àa÷C½ssö]{¢'R àk¤_3î4´t“Q:{{ÞðBѤ<=Ñix¯·ö·÷ÐÃDSƒ¹V}oWVÉÇ‘Éy< ’oF&þ££o7£Owd.óðªðQõôB&bÖök’r?ÐDƒ‹TpÊ#½>Ô7B-Ü$ bß¿Š±0í­í ᰱܿ¿6†¹ñŽÔêÜ Ñê0´<¸1‚ÁV=õ’cήúc¬»ê„VÊúl&ÿ/]XF9pv@çÁÍ;U§¶{¤çáØîJòÚÆNší\öK!ºVŠ&ðÔU¨Cøäû(p`à ØðU5DóÊ9jÔkÉøœH¸ÅäÐïªgûd( ç>yÀ…wO,%8ÃjÈmËo ìÞõÀ“bb;gÂ.øFn ¥kiZšXŸ€w¿®#bZê)GîW‡@XÈÌ”9£=¿¹NÕìV~‹x?Q®x,ãª(ˆŒËÊÄVg9øQlî[š7J7ÇAÌãØ/¬Â_ÒÏ]¹û0Á:ëû “ò•çëÇ;Щaœ5Ó£€‡¶ï뻣Ә Ø,õs lpùw¯™—ùw®MªŠ ü»Z»w‹eÈ“# »² •€€U=kà¿r', o9$ge‘³ÎS®'‚ K éà†¤öØBZ…OK¼Aï4rš¼kOãàq7ÎÝÓˆ’^ÉÓáSêî&Ý•=mEaµ¯ªË$/@­…Vg[dÏAlU6ŸD0…&€ƒ<-²U€z©½r¾¯‹»ö`À9…I4„I4X)fyäd3¦WS ‰«Er0h¾\ï…,Ò|FL$8¡ô¿ö¹&ù¹(m…Q)€5~E?¢”$Ç« †I#ô,’F趚 ­ADÂ"Š%ë®mNy(žnOãI^J­¤=¡ôq ˆ¬},‚.ŽÃæç Œ'ò7ø57üš|“æÌ 'à!7ÑÚÌTŸe`ãÏåv€M,²ØÌÅ¥6ˆOÀ»ÙÞÇ~P‘F(–L?a"„lÂÌ)a0áÕ1„¸JЀÃea®Kì2{ Å ]‡(’»v8\FŒÔi.‹sZøU´0úA°r™+ƒÖú *¶¢dÂ=¸)fjÀ‘ ú9”ˆŠ—ÞvöÂå©ò¡Ò «Û±»É²Ä%M¼Hµ„m²Ô0I«ÿÓ]]aJ3\ä-=\ºŠ€²mu½,Ä—3Kš­<½JR´Û?«}9ÅjØϦ4çQgÓa`qC2{š 1¼®ÿa/Q 32÷É*´—–fQ@¯gðµkjÁè:ÚÑblí°nHÀJ³©g ÝvVôŽ©´ÙRÃ9V™,ß43€ô»úXAf \‘œyY¢žŠ\\gJ³ò‡º{V˜Zf6÷ñ%®E³ã\{‘˜ Ña6Òz[I‡³B&e‡gö‚ô Á™Š9K¸Pz¥Uüe4žPë<ŒºÈ@u±Á«8>G CxÃ"±S^J<¡HPo!T¨úB–¹¡JAî‹ùª¨qaH©àæ ”óÄ'i,éÇÕ+ æQ<6Z)Á€³‹ü¬¶@@ÏR¦VéðY½aá(¯ñ4o«SÙ}ˆÙ.s¸j™¼FÛ²–¬W·èB½-c‡„Ÿê¶g7v`O[F™ïôŒ%€k•?SAÏyfõ´6årÂ]ê-’)¨¬onð ]1I]Ø€T͹{C­¶´x‘hÀ÷ìJ¼šó¥ÃÅý…K"´–®@VX­…Ÿý8Œ#žhîðÃÕ1MáåîÊ>ùSw™Lç*rçê³”­œ1–|»tô¶h±_í³Faal-IpL™RŸ kÚâµ—³Ä¬ÍØzpÀ¹¿íÀ¤Üp_«2ÓMØ3§l ¢hFã/¡ŸX³õ|˶ÙrÕ<È9í?cžèϧlùñRªâ“°Õ¶\§ZŸÑÆ{p~øÇgƒOÛ™µÔ Ì[ ÷?_†Û!--ì7ƒ&~µéØ9¥Ö¢ÕxXG¸¢÷‰êÝ㊬CÛ—ø’E1ó… QvúõðaP‚ÿH)v$]#ï´J8üVY°U&ÀìV[Åj¨:-”‰/¹üšf>×Ù¼ìhŸÈìå\rVéôÈÌ]I "R;/âÑE>YdQNÝZŸcuVh™g>ÓСBcá|=p\cŸWè­.r÷qBl [ȃŽö ¼±5OhE•ÄÖÙŸó P Wah6_‚ï4+&(£K‰ùðÿYÁ¤Ù,²ú.ºgâ<:ǘÙÛÆ0Ywšhu$éy®­ëI5+€¥‚y¸ÕfHŠ é™GÖêªgB¥Ù\†ˆ §áðY¯. 3x31¹É·o~~ýË÷xFüy° Ù„ òŠpHçØ4 ~"rð?¢ûÙ°˜éTÍÒ$|¹"œgöYpzkÊgu¼ru.§xÂ¥º ¡â7EàœlhW•GW£`àG×W]eW!õ.f|Eš³:¨07†•®ä” ÓWž›ÌÌ;åê±<†ß°VÒ°’’gOÕp³ÏÖp³e,³ñ™ÍØù D<AÎX~ŠX·e¼êg#ù‹ª~øÝÿ×LŸã%‡4BÈ««0…Дö3ÿ‘ªý4Þí£û’e|¬ðº¨Èè¾äÃïl¦êøuwÒ¼Ðéy’ÍÍå7ÒXœà*©ˆ\G"}ÚÄç ‰7Ê/5Ø‚áçeGÏ°0Ò]5ˆa?XÄ.úò ûü˜Õµ>öXxd¤¡VØzúÖ(‡Õj«±ô¡Á46rÚ6UˆÊ‚¬Œ‡5ølÉ.+ÿ9‡[€Ø XÜ8 Í#1Y¦:›Nïï‘UÀ;èÉòhÀ–x1oƒÇ?öøk÷W:ƮͳtìCÉô\Ç æÑ–xÃ!•ÖÖo€šyŠ3¾»ýâ¿çL– endstream endobj 1670 0 obj << /Type /ObjStm /N 100 /First 1012 /Length 2883 /Filter /FlateDecode >> stream xÚ½[ÛŽ·}߯à£ý Y^Á€dCŽÅd¹ÈzåE ØØM´«ÄþûœÃ®³ÖÎhbôöƒ´ìéîâ™b]N9¹¸…ré-äT1¨9˜g$x+h¨¢XhÞ8ðлq€ûYù~Å»R†+Ê£ŠÖ!¯…âËÝJ1"•°:s@±Ð à«71Cx‹˜ÅBUj·Š‡j>Þ-¡:õW¥†ÊµPÛÐôPû¸ À¢:æЉŸIhºÜ­°ˆÃc^ ún%óû@…­`Å`\5qÑ …V8åg\úJÓëCQª¡ËPadCx·{%tƒeÖ!ëЛQ)Va­e¼A#_´GùI†‚%¥±V~ò\0¿*´¢ÊÿR Æõƒ’C žà\N7È0 +=Bǘ-ÛX5ª+úW-3cˆ[f‚Ù¨1Ö[ f“a¾µà)‘¡h-‹)ñ<%>Ö›'u‘‹Ù¤-r1Tĉù”æaôUÅ{gžíž\^\‡‡Ãî T`™1à9/.d¡yuØÙrïàmyì³ÏÎvÏÞ]¾ùöü:¼ »g_< »ç?_‡Wg¸Å©^üòÏsÜxýó³Ýç˜öüâúŠ®ÔùþÙîùùÕåûwoί÷Ÿýéü‡·¯_þ^&|P€¨vy…‰^¿ÃÛ4‘´<øèââÒ^.q‹xFÜÚtl|ÊÔ9hsÐ÷ƒ–æ`JnSr›’۔ܦä6%·)¹MÉmJîSrŸ’û”ܧä>%÷)¹/’£×¡³Ý·ï¿¿×Oß^üx¶{|ùî‡ówC{éÕvŸ¿Ìã‚ ƒ¥B”Œ2E,"ÔV‰ª¨EkO=ÖñmØ}yùâ2쾟|õù×/ž~÷I¶ï>ý”˾ ŒÜ0=ÌÓ[÷€{3ÚEüÛˆ¤+,™!Ò„ÄsD¬õb±Êv0Ì4jÉ70¬k¬ÌÄGp|ýä›/£¬ªà€•;þ0 !E1ÂÂu9j"kâ@$Š@:(ì…ñí(E!²ªB²õˆðìªpÄæÞ£#ä {Ç–d;…€ÃDLRÑbC´"I>[?l °ºêº`zf ƒŸ6?¬QlÄ‘jìª[+B¬µ‚Àª¨}èÇ:®«mY6 ù!<—Ô ^Éù ž›zÛÎuÍrì ˆuAH±S€¬ë2Úr$+³ìXòehHø×Lôˆ­¶U-D=*\žÔR$Aë‰ LG`HZ5¤zŠ°V”¼C‘qœ–šòņ]u]ŠGþÅ!¦"Ö£&ÑêùæN Ï=_ÓgKL 5”"‚•É`®°Ò¾|ÿ´ ˆ‚»©Jd¹DÓ ©SDsd–;üåÇ?_¿[ÑM‘ÙFÝ ¯p+F ÆŠTqÝm 0C˜"Ó{•” þR/iüÝ.«åÖ#«(eÐ4QôDCY#ˆâõo¬*Ô<¶ü+ -;Yéô5Ó*1 td§`¡õ+ùy˾傴˜X²@ãB€÷$T¼‚¬†~³ ©Èe’ Xw+ Ï }àò€“<ýÏÚ^â° Vô^P«C*‘í ”¡Qþ¿EùšeÕ5Êè¿þíï4RñµØš¹xÿÓO¯>˜+yM²EÍýħEÈåöÓ¿ÖþÿSÇÿ¶ÜÏ Hwunõ ê-óÙà¿·EPµ|Ð"`Kè÷¶Ø©¥4uûA™ƒ:möÕ:{tûAž™ƒ)9OÉyJÎSrž’ó”,S²LÉ2%Ë”,S²LÉ2%Ë”,S²LÉ:%딬²f÷@Q®³¿R@!2,Èባ€Bˆ¯×eÝÈØÆž(¨„ëC‰ ³€JÈ‚yÁ±.¥BÜfK¸ L•Â3’9üº LÕ¬G9÷ªLrB܆#‚Ùhb¼î(€ —~w¼|ööß Oß^]¯Ë,\hâ ³@ä8†ã~ôAÒ-ì”gÚ=éVöË‘hSÝHîX6vXm!8£Óßû_GìÔWU«d¶“°<Žx¦ZQèÒ~;Þç’udLÈäPGâ0òŽÀèµP/©l(þIVÄe¿ ¸8óÜ~/CÚ¯pƒ}€h KÕÁ>Pëë¬Ç  Ò¾lÃêqä´âzìûÒ¦)Z‘A8•] Ãõ¦Á=t)ìöŠ"ÝÀC?Ã×Í+ ¿(Ño`€‚j—£0fwkÝGÞ@1Xê‘S'Y×_‘Uc®,Ù‘ø¹éÜ@ÎàAP£(Ñî#áƒø 4m/ut:žÂqJö­ìcjCÁ;¸{&‰­6„1¶Ç­l˜ï³ÆL@à?ìýr/yV•a¿Â>ƒòÇo¯Y9£R†A²œ—ÂÙ@8TRl¥oç(ZÙ¶ÑÛÁÄÁ„m`½~€qÜOèÈl7¶ÑTáÉ TÓŠB…=•î}³Ì†¦ðŒ‰¢A;äÇGP¬›ØtP_2r(<¥/-AÉ”,o·ܯ²¥ƒà1ö$!Ó‚ªK’ ]UY,yÈXa K±(cr\¹Ç×+ªÁ;*$d4î!¡³J@vl94ØÔañwRSçÖƒÕŸ,6ãüÈÓÜ7Á‚/ã?*{ßâN%·NC‚OµìD$9ƒ½×CÝ¥[¢[Ý¥[ ¥Ã=¤[M¨ÎœÔåüÇí†ÒÒ¤ú} %]»ÌvÍvÍvÍvÍvÍvÏvÏvÏFOÉ>%û”ìS²OÉ>%û”\¦ä2%—)¹LÉeJ.Sr™’Ë”\¦ä2%×´êq$ áéµo¬l€#i K”A*Gw"TÖ­}À LÜ·d4À‹âÚï&vçÿzÿúúíåED©²&÷OLM7H˜¸MíT$¶âVUA(­O$Üko0–cHVåT<"̓ƒîò\&Ûk<Ìé(‡êó›µ±uìøÂôu–ÃþìæL¥Û‘:Ëi°ZÝnÜJGuÌs[.¸®º¡› cùèOGÞbeÒrÖìfK ;ilÕ)–¨pK·ãúø²uh¿³_o3VŸdU¦kÎcr„KRT·"cŸlœo¤³"hXfK|Càw#ˆü1 Wï¿¿ÂËd…¨ílͽ5.à)t~Kóì@åîþù<ò¸ò)a»|7H{\õ4$«.Ï8êò“ÄjF.G‘ìèºçÙ3)2ÊVçÆM`З´àÒbjdnèðæ(¨ö?5ÈÆÓ‡Òv‚›ñ3()«,ç?ùýø^J_›²òK¬)Èœ-òlt‚wŠ —šOû¸l>ý¨ eÅ endstream endobj 1821 0 obj << /Length 3436 /Filter /FlateDecode >> stream xÚÝ[[sÛ6~÷¯Ð£<!¸èLÚ&é¦ãMº‰³nh‰Ž9‘E—¤ìº¿~Ï@Š hY”´ÛÎ>$&8—çÑÉ— üpFÃßï.Ï^¾vbˆÕZN.¯'L&„%l¢"L°ÉåbòËôÛe}S¬¿ÜœÏ·Ó‡Ìÿ-³yq{›­øj¦uᛡñn]‡oê›ð°ÈꬼÍWéªöŸ+ß±*V³*_}Y/Óҷܦu™Ï³ê¼Z3]­—Kßq—Ÿs5½?çtZÔÕù¯—?3F‰UÖúoª(¶ƒ”0ø§&%rÚ¼|üø•´Ã/'Öhø ÷ýûË œƒKøŸ…™¼¨zr’†Hfšîë™°bš¢8ð¡ªÓ:Ÿûçá®m<©‰ RófɆÔg) Ñ ŸmJËÌ?dçLMŸ/׋,Ð~]·þÉé"ý9þŠæ‹4´¤þ*ÔéfÆ4'Š«XEd%Œä<‰§Ä†¼ò«:G•ãc™Õër…tábÆ}Ðâ…s=-JߺʠD<ëv'-œGÅôòÆ/£Ÿ^˜ ­ŠzfëUþÛÃõ LJO4<-²»¬iu$cïM>¿ñÙok€F±ªBOV†©ºŠ íº€PöáÛu ´•·E™½À!ÆíE®tw/r•¸½ˆÍÕC^ûeAx×ÂëÐ1O— %ß3ŠÌHx–[ûÆ<»m¡¢F¤'_yRªµ'WOçiåu&èô] Õq ņÉ÷#Xñθ™ÅKžÄÐ8¾ì®@›É_ùΈoK$mÙ¦¸è‹Fû fªy™_…·< Æm?|¸.–Ëõ÷´Ö雯Ë2s†—«ì&ÅMpŸë2@ðº7à.M¿dßôø–ß”p)kP4üõê‚]³K¹À¤V “9¬*…ní Il#øÅxejC4'±„HV~Φ•LçuC£š¦u¶øæ|¦ Ø6ÜÛH,ºÌ³ðuxt’ņv[akZ–éc5rc% DÖ ñ㇟?}ÿíNž4a–5ߣ1µÞLpFŒ11¼¿ÿpñܲ,{»j#qù—~=g`ÖV ¨½Y›9Ÿë±[X÷„3‘O¸c¹ÉNƒ¹±F#ÊD1·IX|4­ŽÁì;‘®y Ûb¥lBTbOŽ Î¥Ù\¿@ohW_´ÀFÞ@âã`K5¡Œ€-˜• [¦ˆÞØÓçá ¼B(¢+nü¸yp­îŠÕbcTBû[ê8e*’ˆÖJýôîŸï?_¸Þ\žývÆœÃ`n%ààUbàóÉüöì—_éd}àþ‰°fòྼ…PU#ËËɧ³øÈ=ŽdLÒ6ĽãçØè…Gõã]¶Ck4ë$G: Ñs hrþD #< 1øóÎ}Xü§ r7<ì9†žFÆsi®Ž’ñø9†P»‹ŒaNCÇÜ+ÿ‡>-ã“Ðs$RíOÛ¦‡)K¨´0—&ò˜ô€EbyœÆ.È@¢y ì;TÁÏ;4kЙ“Ø›Ç %ÿŠl¶žØTà¶Gxö¡I(á”$bBá\¤j®}.^_„:QÄ&€?÷)‘´£¢‚P/w¸a vyFŒ0Þ7N’ÐÈQAÄAÔÄ1C7«cjŽ!^ãaðtHÜ Ôψ»Ý7Ç3()l=œê/Å`‹'ž£´¡ÇÌÑzôþÎâé:îЈ´£ŠÔN‡Ü^àH½·rv(À§ÖüÈŽ¥ü4! À…Ùƒ"”èè…(x}ǨøÓ5Ö"s4› £ Vc#ìÈ€¸GÏ1©@üfp.put_ÞV YMx²í¼zÓ`š˜Lf¯†Âð©Fì[îŠvN!*0&–™ÿWQµÁˆJq~d°^2¡b;™p_"jÖ\"j®¦¡)¾šÖ´[z͵ð·nh˜#>¢×ý;/øÂÝBBÇ]VÂÇ·îšÛs8=pçVk/A„2*éƤŸ.¸ _éV›5pn®·“pÚ áêÒÓçoá«,[õZ³êèûG<ÚLß­<™AâÝú–mt%œP¥{føÉX$À|Dú;aïéQ9ÉSÊ‚»ýÝOštj"úZYWµç7]b—Ç–¯™Äš-¬†“±ê›ÛCy׫!,@£e\ÉÕ H¯–YÜSí0#ŒCvõ¿4#rœéã‰l®+7·ÙÝM¤ÂÔº«"ÍÍŽ»åh^…¡íACØӰÕ0á§ðlˆŒ6`¹ˆÉfH™¹©g7î&ß«|‘…iÇ^Á5cv\úá'j(w ì=Q¯0xY¿¿uPxB'F\¥n ÀÛÒ­;¿—ouT¿+%Ñîþü¤Ð½ë·í(ËZŠ¾Á›ZW‹›UUSLsõØ+ò»)ªz»š¡íNWéò±Ê«N¨ºÝ–¨àå§s[¸ªr·U×Óû´ÌqãV/Ó²t¹ñ#^Žão5Vx±v[8[ yˆ«µQ^%ø³ûôbä}¸uF1Ló&Ø¿ÂläRŠ°M-ËÅÈ•œLüo@lw^ˆ# 3µ©}üøæõ343’qûìb’º+î0ÀUŸŒ,tB­^ ±)íÐcK;öÛ~Д㶹ǺjÈüúʣđu›¦79í}ôËL)÷ŒÕ¢-r Ç,\øq m¶–«¾[ÞoêF;6Û¹O´Ùñfo¯n_Ù 5±¿¶ç/¤ï˜]>@úªEÕX/lˆÜ¼#KþÉ¡Ç ‰ÃŽN\‹¯êW‘•<ïL¸8Ì™ðÍÏBq&N±é¥³Û\vbGP¨:Œ¶ÄÍôA´‰pa 놟ÏqÙþüN45Š\ö0Ù¡¼WìuŠm6¿CdŒÅÅÿ'/õ ¥œÌÝókðG{a«7u´MùuSq_—YZ7^¸)t¥{ùR¯ö:»N×˺cZ†FãŽâP€n¸Ü²1Œ·d°Ãâ:³å†Õ»Ôûõ[¬=Åe†ì`èW[vpoOƒÕ ÇæhcãÂåö¢^&ZÜÂx®ÃïcPl$˜n|syöäu endstream endobj 1862 0 obj << /Length 3653 /Filter /FlateDecode >> stream xÚÅ]sܶñÝ¿â©Œo‚í¤3I·Î8Ž+©M§N¨;JâäŽTHžå×w ~uÒ÷A"¸ýÞÅÇ· ¾øû þÈó›«/_Y¾p,±V/®nBÇLÄbaaB‰ÅÕzñ>z]¬Êí}Úä×ù&oÎ~¾úîå+• >3šÅ‰‚9ýø?-6ÑÕ]^Ÿ-•uQyßäeAm‚ÅQÞMºÉ¨çcÞÜQ_}ŸVu€Vùí]³¼K‹5½×ù: SüÄ Gd€Îü™E…„µ/òô<)%ã*n}ý×·WopÉá¿so&jÇ´HÚ¿çò\á7çøÑb©¤aR'‹¥à,1 "‚dl¢æ.£F]nvÄ |+o&ÝM•õ}Ygk|×QýP7Ù–úŽ§V˜˜ÅRìQ›ÌkäXà ×íw–n†SóŽ3Ú0«:eÄ¥¥t"òBDZf8ƒÚ°kÒ}ædESå rÏg)$sÆùìGæ‚F^œi}8ðµW$Ï?£˜Qn}êyÊÒ}ˆ£¡/¸´-4€ŒÄPÿ«]˜WÛ²Ê΃m4Yœ8“&`­¢*û‰sYd[` ANÐ i™³û Ž´?Úã@–©5°º*«–njoê'aÇÌh½¤8É*#$×y‚ÇY(ȞݾÊýÍÙ5D‹˜4K9­vUEÜw:Ê·÷/Œ µ8``¾5 hîÒ†À0ª3 =€ZæZ4v_•«¬ö~ÀÏZ¸,÷iMÁǨ¯wU^ÜNÌá:]ýòñLp˜~Mð*÷ fب^vCº7þjS®~é&«óßO¶# LzßÉøxC ^‡çm˜“0÷¢Û$´-AÎÌ”µf®mÙ6­~©g¼˜LÅئ‡Ü"=…%Ý šÛ]ÝPëºUº¬¨C³)é¹ë%¡u³+V`ô¤œbœ K^üãòüH~ƒß·Igãoa†CL–‚™ÞfÎ $ì¸E]¦[óÍk.°7Ñv¬½õ]¹Û ŠBö€¼Ã'XºÀÀ_ߨÕÔ _Uùu>9Œðâ½w¹»®³Uˆ30&:l¬…€ ZO¼¼aõZÂãzE¡Ùã“Œ‰4FÜæEA¥}|›1àÎün¼Á®š²Êo£"€ïïÒÓš³ ˆjeôÝß‘°`´]˜—½ñAhŸÑz‹4 æIù ÉÚ Ôµ²òÞ`ŸAêó95ÒŠ+f­˜iDÃ[¬E´+ê‡í6ƒ¼d…mSl£Àîü†ž ¨ RŠmð°½ F@¶É·gH²8G¾¾Ï*¼Í¸֣ã}˜Ñ ü3KœÝOsäSÞ8Ö+Ø‹R]¶§Œ ASÉè õõØ©³ìHÖ“©}dÅ)¡±Ú¦„ŽwÖ€ aRò¡ÀÞa¸NÏ$ïÓ1è]Ê*?aŒƒ-ÁZÅ@*å}.f ö#A´HZ5Ð"|Ø/­ŒÊ]³,o–«sìÈ(»Í«²Àä£ÆÀm­×:ì&ã²j¬rþáÊù%jZb r*÷˜wRjÖ;G?A÷,m¢NS¾>7ÿŠ°­XbZ°Ãù õô¨×§¤ ì"ž=Ô4z¤ ¼³Æy¬ÁµhðC#Æe}.üåGDð(VióêTßpðgVáò<8»R3¥Ç¾îÇ3ǽKV.J×rï“UìMa»:tRî‚]í¡e±y ê¿ïNé½ÊÒ’¿ãGp±Û^ûH‚_ÝÐ3äJØ=̱° s,j'ƒ qèu¶J­¥ ãÚ ƒ$­ó.Ï  º.WyÚx €÷fNoÃø*ûu—WÔ“Ü„”†öõ l,FÅ8‰ù@;33D§c‚ L0-åsÔnøŒÜgœÃtx“ÂöÂE·!†úK@œ£ôŽ‹§˜&;óÉY;£ÜZK˜è0Òç­¥„ +cÆEP$a±ìä6#vU‹QX5é±³GÚóÂVóä]x™¤TTÃU ÎFÜ[a™7Ýä¿gë¶Ô…OÓ–ÞLtWÖͨ8Aì+t!®úñeø~×xÎ æЃàG¹%ñ<Ƀ*{Ó±kûŠ–€ôÖ,ÉÖÙ–EÄk°$°ÃÑ„ÓT<ãã^&Ð$¾c­ÂÉè‚ç3¾‹Êç­vÅ­‰;­–oظ¿sÿí~SæM{áõžéj•m°:M¦žlè°“ŸÉ_އęëløâL$Ì´sþè`P. {Ôq¤Å‘+¨=”~…¡·¥çŒ¡"/µ}wU{hìk­ö"éÇÅCž¸­~@³=À5iSŽzòíH³º9üžz•6Ï(€«‡ÒM‡AÜzÒ©pÆ w2H¸Ë‚’ÿ$ Î kÏKµQ¼ò–Šc(©‡‰:”°Û«@¯ÃLw°l»e€@±[xÆ…”[¹Ykj¦Õ,I—’IÁŽNŒhHðþƒ¯ZÃÉ…«Ÿ¸}Ø—ÓltÜD>i?h¨„™¸Kó ­Ì(ñ”® þP¿ÓaYF/u¹ ­ö¨Œ¾AÞƒ[ Ñ!ÂèTl.JXfõ^–(e‰ ëœÆI7ÉSºˆ+f(…•Ü8“ÄìšJ…NõXwG Ðödžä4]Â̤zd¢kòÕ÷B{²œM2fø  /Ÿˆ–NªIϨd¡O5Gõgx÷õg5õ3ÃCCØ!`1"6DÄA=kzA™+íÚI<9¦ˆƒEc+€\ø&î¿Ixmµq|8J‹A AÝÊÍ& s_?YvLâa =â0XcTÇý£*–ÊJ0³‰úôëYK gUVßg«á©-!öûßa†%déVºG0]7fNtVµÎÀ¥nó"›æ®]6êèm€ø‘Qô5ý½Êüœ¥<ó˜ öˆIâIsPzTßµéÀþÑS"†glÊ—ÔÚ£OŒð0ÁŒò@lÍvÎ)<qBft<øKae]Ó-•B致ʱ‚U¿L« òùYLPè_aýl=—1* ›9 V(.N8ÞÓ–îÔÓ½ãªí,éWzóÅVzÝ®ôíÕ‹__ÛDÝx÷C.¤ƒà¢Åbµ}ñþg¾XC'„}¦·øè‡n’YDd³¸|ñOºå4á aFÓLøô‹^¾ûúâòÛC¢ãÏBà<}² i?}°¥Â~Qú– ¼²”“05/Iaê°S€0ª>R£ÑÒLf"£½º8xôç˜ê7wGGa†õº·ÿÝ'O‚ë‹ý äIù`lÇä=a†ã“Íç¹>áHëC®Ï—XÓÍ.›«5™˜q+zÏ6Êe–Fb%o47§ '#ß/ ;œý›˜ìãÑ{F/íÕB3ÞÛ+ÖuáÏ ·ä0ISíVÍ® c1‘. ºÑ½'ܵp’ÅB~oŒÆlŸíÝòØ u© ל˜ðl¾*æòÕ‰Üe › 7>Zò÷&Ÿ¾ãÄÕ × _PøþYÐà6ÅGX+}„S¿ëgHáAú0sÑÔÇÉ/ Ⱦ,üú°G±Kk?‡G‡™¸¿G‡ÏM2Q‡y‡V cpÃX çñ§8t¼xli&ÁÝ!T3ÝŸVÌKRjÅ÷9”RþxBàÿ=b%à—´ùä%ÚW3Gä=#béù€…aC@ܘ\™\ÈU»Xg«¼îÜV»ÃÔ6ûË}åÔˆçí…†Çb\;FÞoò…$ÍD2¹ÆÜžâ®ý-O_Ú5%8³|Õ^GÝgN˜fÀy€7¾DŒ7P›‡#ö}ãCæ·?à6çj›Óž|Û–ÙÛ±~LhâcjÔLÍ ÃmåcøúÝ"$ã´æßgB€2ø,i)Öù –n2º4Œ ›ªÜR‹cá Ñ‘¿Ÿ/8û-:<=|¹M•…kõ ¼ÆáOºëi¾“]á Ú#F`0",*m0&ƒx¸ÍŠ5m_§•TºÈ´(ž•aòÀ¨°ù[v“î6Í ­œ«v8f†Y¥/ðٲƜœë½”ä±ì7,4å ¿y‰Aö?úRµ—0©æ|Å <@\OÇnDœª2øv¼§Oìð' 3Ùèèp\BFiºÑ™?æ’ýQÑÓ°ñå÷›miÖ1>õmBî†òpš€`ºüL7Ÿ} {«lC*#Я pæÇØ=þqBN¸© Ö{ê#&· ÙsË5µÃï#µî÷cb¦þc®q qê%{ò> stream xÚÍ[K“Û6¾ûWè²URíÁƒ$ÈTå°ÙÝdrloìÝ=89Pg†eŠTHÉãɯO7 Šfæ°[ ‰W£__wcøìfÆg?¾âö÷û¯¾ùAe³”eIÍ>^ÏD¤™Ðb–¤1JÌ>nfŸæÿ[D|^îoK™fón—·]ítÞ–7·ûåm^oì·rStÔü•Çüõßß~|ƒ Éáñ¸’W [WÐ'KçûÛ‚:_7íÝBðyÞnhâ¢*·eï˦¦›C[Ö7Ô¶ÃÒùµ³Þ7mùõýíãO@ÙRp–Åí×Ç÷@5gþųÉw¿ü‡qï$ËÒz˜á= JâÎíLt~£Ã‹R‰Ô üN˜þKÃáuô[7{j¬m[Ôûêžó…äó/ Ïó²ÊWUÁ‚u†õŸËX°ˆG@nIJ(¢e)¶yû¹Ãñ£í)Á”Vn{ß.–B*=ÿa!âyÓ.–Z¨ù¦ØÃ:|ˆæxôøò¶ÁÝÑË}C/»bo_ 3ðMYïöHH¾-b¾/Z;YWg˜0ûd¦ùpXuÅšQYxì¶'JÝ™)—–æ@ üððÍ r´Âœ-`0Ÿ¿¯ŠÜH;q϶ö·¹eäæ°«Êuî>OÛ²°Ü.k×Û~íUÚêà7«:( ­ëØn‹ #^FÒg½,Y[JÉžŒDU 'ªc Õ,Ú‰p»hAÍܺý>7ed¬P(Ã9áÌk$0¯Ê? »m”œ£!Åfýæz|MåMúů@î'ó2fi–G–)Køû[äÑ1¹æ"O╱ë¢ëÜþW÷£íÝ6]ÏZkrF»§-ÓãW~äÆi3²¾_¤pB]W‚ÊÛóÈÛ @÷MÞ¶¸P~?H˜á/°~±™ ”™)¡FÄþò¯W?pYÜ[¿ïÞ˜ñÿüøê÷WGÎX’Œi8ü8S`*ål½}õé7>ÛÀG0¿LeéìÎtÝ‚-M2hT³¯þMþ&XMüF’fÒ©¢E«fý™)S©p;»=½y0zé¦(òõ- êªà8ñã®mÐ¥ôÓ×ÔsØÇqxì9Þ]h¸&ø=mŸE ~>Ng±Ì˜”ñ3T\d°—ˆfâ2y¬}FÏü û¬#õ }–øR¾Ï§OF‹³è2ú|ûÌ.#.aI=ì\!Âa‘Ž_‚¸L2‘ÄÿgÌS|)_€>%L y9}=¼!#©„De­©šK%„5—øÍ3—øˆÒ6y úÉ`W¡ŽZ³©¬ƒÀ†5ÎÐZ¡mU ÁdxîZÛζ û ¹€§—²·?¼3A:¿*ÆU: ¥ÀyBqðëî ØqàìÜo­¶+Zöáô)0ò×Ö(=ºûù??¿ÿ0–Šk2ʹÎÞá.8; bŽ3C8ðR.2>é"aÛé®ùïB€¬L²!Ù5î×EkÐ…ÙvÛl©eQP~ŠQè9JPìÛb@ ¹]€?*ðáá6ÿQ\ç‡j©85L(F± Ö^f³ã¨ôºi·ùþHÞNaP»\°Ï×5úiàíª¬ÊýýòŒ˜Îü€K¦Éü5J WVR¸ôÃ]xmAðv€øv=PóÀªmk¢kèž×yußÑ`e™¯Kˆßa‡ÈåÞÁ÷@"—u±%¾CGº7pHMUQôИ¶h©Ô%††Iž¥Ê?§ê1gIòB!Ü°¬¸,C7$)z±ïtùnHØ˽d0 ú˜k nJ™\ORšÌæ©à89!¯Êó ‚à ³ Ž i pRêYõÇù·‰…SÆyÄ`Miäf1  §ÉÃÓóÌ#M³Až94zdªá4†MBF€Ý´îÄ‹\q…î¶9TZeeßù|}O¯÷nãýòÌÄÒÁ'›j5“ÇvZ„“@Œ§GPz «áŽuˆc%€&!Ab’õ0ó [—ym’ŸvüOï¾?,ªþ<¿£Í«+"5¶¿äæù<¡ã­{JËz]¬šqwzÜËD[7†]¯é7,§qáèR¾þìâ£Jw¾û6t2³eš0®Ó+@ú(O"Sí•ç´+Ïé Wž¦O(Ä .Xʳç—âx_tLè°a;½ÌÁNsú±‡Ž4L‰W±X˳â…á{ô ñ0:Ôh./ؼ4”êyDž8¥Ú'2:L&²ˆ§Â¯¤yB%Ë«‚z¢sªÌr"¾zB-7SLIõBÕÜé€ܤJ˜±U^Qj{ØÜ\Œöt¦˜ð¥?BÞÇKš)v5À]Þþe#bÚc‹1É< Ò¬yèTŽjã}ú¤]ˆt^äÕ7ÈѪø:åa¥ÉÚ»¦¬÷&­3‹Œ’oñN Ïadð o,mWÜDÆÃA`œtÙjÀ¼›¿=^l|¢Áb¨;H¹I@§ÖÕ¢ˆø脧àRÊ‚Pæ·zOušI*fR÷s™üuʇ¬–R¬Lˆi2´î_ýBnÛF¢g1ëof`*ßïP«µ2Eó{jÂ")å_ñÿÏK¯Žp1égp¢‘< 2g¹ˆ{µUã ƒŠ´ û¡Q.Í}9˜¶sÃÔlç‰0Ô9ÀòçIØꕼhëT‡­=QÓð¢P2ûýs1BWChj¡í(Ly˜¬S²wsSL Tzt¡ë©£I)Æ“\ÂèhÀOQ×Iä_ü~0N©sJïÀzȳq‰:ÎÁ3¤a Ë~Šmô§Ü_Q‚˸ÔÌÝo‚ï^îžz¦@›’£x…ª¡ß•¦Â²ì)¨+G0T8&n•\ˆº~KÆcU\ø)Àgê'¨¸ 9‹FÀ÷®4PÊ\©6#É°joAŽ­ëŽehBç¥f2Ñ—é¼YÄêüù‹6$=Wš,$À.Ω²~„*§çTùYš,ž¦ÈV‡ ÛÜó]V×ïJ“ÒR±2*îÎÖn•Ÿ¾Å'§‚Ø6*hú6ô»²CŽ ÉJ>¹r6:}¾ §†@Ÿ#ÄYž‚žê„‰ùMq圅`:KB`.* ` ú0Ünlê}în¿å5®uﲟ7u‰Ê¼Îflò}ÞGS7"îR3Åé®Ã(¤t·òûó—¶ÍÆìÁé > stream xÚÅ[]\5}Ÿ_áÇðâ¶]å/!AØ«!‰2‘vÙ„‡Z»ÑF3ì|¬Âþú=ÇÝÕ“é;8 ‚Æ·¯»|n¹>Ïõ$m.¸&Éiv±Vq=ºØRp©¿ˆ®ÔÎAr-rJ‹®çÀAr1´ñf¦9R%—#ŒpC[ãwÅÅ’Æ/*>2?x£5ÊÅG ã·kÆÌ_BJüYíÉ%MÒÅ¥œÇ<¶Ö°FÏ.µ¤ü®¸Ô˸[„ÎÕzs’Wë݉Ìk!8ÉOˆ)B!9©%s$NZ#uR>Â(;ÄÜBqš(¹…êTÓø®Ao›ßv§ c‹ÁiK‰£è´çÎQr9t"Àœ:sPù¹,±pZǨð§x–œ©–ÅåÞ†8u%Æ!.»mpT\‘>îVWrâÅæJ›pOŠÇZ [Û\ eŒº«)ð1$¸ q]Õñ@0‰ZWÄÁ0Æ]uØD®&ÙA™\ 7€L°†TéãnsMzé®å¡…™•N)]ÃmŽ`T½Ž»4¼¡UדŽQv;ÃQÍÅ„5´º^”˜a¸½6âÓî:~Œí2C|„Xdž*‘?ÊØ  ül y"5êÀ›Ë0j.ÅMÍÓ*ñçÒ+"7/qjLØòÂ"|Ž8¤ñwØUÄær¨€Ø‡g SÆSݦr{ˆ3éx~ª7e¥°J¿*uÌ…˜D#ÃÂS'üFåHhc>$ ˆ"T@£nE韪’ûÑÇG«/ÝK¸´ÂõŸ»Õß¿ûÕæj–PûlÏä”}‚“vOK¸1ûñÙé¥{øЭC!Šm?{ŒíWxÁæàiªÛ‹³®Û è/7›óШ6 wªIÃÃiµiÂ;6 bzã­žŸ½9Y_º—nõìËÇnõbýþÒí°¾øù§5n¼þçúhõ¸×§—tŒ±ÌÑêùúâìêüÍúbãšã»o×?¾}ýÅÙ{÷2à‹‚GBú ½>ǯéJØLüüôô Ò^n‚(ñŒ º4û¦í¾¨ ² Š ª š úvЃ Lr7ÉÝ$w“ÜMr7ÉÝ$w“Ü·’2·ƒhƒd±Ú Û Ø Ú ÙÀ$G“MòÖ@~±?C“G«“«.ÇõñÛÓ­¾8;ÿq}>v!|¿úzõÍêÑË8.¸qo°åæÉøX£Oˆ\p@O * ×M0íóa§'nõÕÙ‹3;ðÍ£'/Ž_=Húê“Oh?SpÀÅ=ƒ’‘|Áö,Ùà˜ C$úŸ,R¼ Ä#´z& …ÇG]RG› ùÒ˜Á@:ö)æÐ8’ˆWD‹‚ÝPäÜTÅÄK”*>Çx¨]ь娎- mêY†-Áxþôo'>Ÿ‡!õtÝLSÓSrK ¸ÎévU<=žŠ!•ä±/·Â5á$É3PåNs‰‡óVdaÏRË€h†÷¶e ³7DK…oÄó‘% ó7ˆB.×ì3rˆDC¦ì‹ÞnÏÞþ—µÀñÛ‹Ë™á3øŽ4’a!X%?¬q,W\÷[qœ|÷í̸™±C(HÓÒÕ*¢D_%P- Ÿ´ £ãiÿ¹¬¸nPDÂz¥±mñ,e¤6Ïæ0Kõ]ö$Ô'Ÿ~õêALSC·fÏ>nšŸg7„pé{lK¡BâL(ã}Bç¢H]ìyPàù‚º˜)®µº³¦*-²gMi@T©‰e }úÅDMÐGQ[)|Å)ú¸ »äì{º}GÖÿ¹z}ùöìÔG/3ƒªˆ¼"PLŽ÷¢3mù}z‚“ˆÐHƒg?ÎÿÇ’g¤Ôw䯄B­£f©„ὕtÀ­‰• ¢Ù¢÷äIŒ&R?¾‰ :\ôë.D+t4’¶Šëv»"ž<ÿúdfü„7¢‹Ú!ÀŽ¼t ÁñT’h' ½¥."xþ—/çbÔk µ£ Êwha2ˆ¨ì}ÈÒÔQ[D¤¼UL¸£Ú,sSYA.í.Â-#m@Èâ¡$%2rF”9ÉE0ŽíQ$s–ŧ ðO4@•„Ö«N†ñP"ŠîÁ—ÁGÈ,G4Eä5!Éë!SGB¡‰º®UOª2¡Îl§WÑÃ%®+PÀ†$4då>0~é!äùFaÇ¢½$×HÆõWDã‰ÆJ*Jþ wÌ6ZSü;-ù!yƒo¼ÉDî%oðšP™¿›‰,é×L¤Œ¿ƒ‰äË„-ÓfŒ]4Æ.c±‹ÆØ%»•ìVÚÝ22OŒÌ#óÄhB±EÅ[TL²˜d1Éb’Õ$«IV“¬&YM²šd5Éj’Õ$«IÎ&9›äl’³IÎ&9›äl’³IÎm&mÉb>„ìJc ÒÙž¯ ¦T–=/L% ƒøÖ¯ TAŸÙù"©!ñôŶOm³/*ÌŠmSÉÆ$À…è–#b˜±30¾¢Õ˦¹`d,!1õ%qîÆŸ£…lp(*èa ÷À15C×ß¼‹ôZÈŒ ƒò#š¯}Ü¥YjÚã`AäèA¢ Í ù¢ µ†CÔöŠ6/"Ÿ‚«½€`nmÏtÈÁ8JÅfHó‰^à=éö͸¸úÿâ÷,b²(½f2ìÉë t±H8ôÛ‰×{ZÏ©¢†-½îÊeÆ:€í¨L~½ì^@¡^`e»·æòe ¥}WÃAB3“î¿Ž¹eD")ؔԭ“T2«¸î‡Ój(_”Ä%ÖEM‚®¯ XAÒõçç©„M]í(Í=hŠýcFÏàâ-4¦À-ÈDFŽ€(Ê>‚ýÍÛ˵ ¹çWŸÆ4Š"Dä~ …œ;êл¡¼;ÿ˜óD(èÈCÍ ëøXø@ï„r~vµ¾œ«4¦ÚÓµRjÛpœw y·~ÿæùeŠQäy>ðW¾árœ•©pÝïbdnâ‘•¾"Òe¾š`¤_.QçÖÊ1)zO8±ßƱ7õ…ª‚Šº”E sk²HÚdŒó<˜$jÉ?㺖CÐœHzÂR†…I+ºˆ`n)$%Oï;Š€ÖîÐÁ7çÿº8ùéõùÅz¢uj´Å‰n\Àñ|> #;Óh$yX í)¾FžI÷ªãÙåùÄØt1‘Á+ÆEOþmÌ-á.ñíXÛ¾ÛÅÜ›÷'w è`¥¥k¶."˜ëvÔ# zøJšñ*ltªü ]‚"BJ•ñÎ0b7vN’p½çµöÇpÖfP~1•êæýоrì#8kJLz £ÀD¶/‰öV…Ó•ïdrÜ`i*|w·b²³’K`“\†ª Êà“š‘Çjõ<³Û£1ì/HÐÙÇen.Û³m"yø#_7‘= FÏ¿…ë|y‰÷¤á?œxMóìwÍÞÒðc‰è¾÷Ðð7NúþqNþCæý&'ÿ![Ï¿``-²G yÞÁá¾9{ƒ®ï!ޮ³7èúlLu±A5ÊÚÎ7;SܪQÖÕ(ëj”u5ʺe] ¯&¹™d;›Üìlr³³ÉÍÎ&7;›Üìlr³³ÉÍÎ&7;›Üìlr³³ÉÍÎ&7;›Üìlr³³ÉÍÎ&7;›Üìlr³³É}{6ùO?/<—žP†8ÒÊÅ3¢xLmüI‡—=¤ÕÇÍÐV?”³ŸIÄ*×í¾€fö¡< ë̹-º`§ âT{Î]]œ½;>{31=ðÄ™@AºeÀÉìõ»"=í ¨ U—eÇóu$ô:°ÀVlû‚27h½¯eèG8ÉœŠ<ˆ†¦‚F·å@–‘Èð€E1Ì6Ž„`¡ãOÍ6$ ×#T’xL³]ƒ@)+¨&ªT²Ì¬9æÑ]ö¦K¦¼¿»xòøé«I¦Ò29nNt„0þÝÞoÃñY!àš endstream endobj 1927 0 obj << /Length 3156 /Filter /FlateDecode >> stream xÚÍ[Y7~Ÿ_Ñ/ HðŠá}0°vàM8Ž×3‹ÖñC¦íi¬¤žUK±_Ÿ*’}PÓÒŒŽÄzu“ìb‘u}UäÐìSF³.hü}quñÝ?•Ì,qZËìêcÆ '̘L+F”2ÙÕMö~ôbüáê'H{% høþg¡Ÿeº¹öÝ‚h«2Ήa*Œ¢8 >™0C”P=Òب‰0:´ý#NÇúÓ=g3øT †åa·™"Î?­$ÖòlB‰s‘cCÔ 1ÚdäWìCójŽ b;˜ë {$±Óò&Ù}© E$l¿ÙGù±!¡~? Ôçšp sTN€°ÖqäªZå³ñ„+:ZT‹ß‹eU‡·rØWXÍ e­&¾˜EbmF¼ù/¹xyuñÿ üŒf,ãJª\¦lƒ“Ùt~ñþÍn –A(Þg?tžqPCx˜e—ÿ æ“ÌÅ•"FJÚÅíx÷ãåx"u`(~!ÊïÏ„1F(›€-9˜Þ^¬ç×Å2Œ«>†ßi5[ÏõÀê  Š]«ç‚8; ’3qŠ7ž!i-mâ!§@ œkÃÐ_©¢ ܳŽ›åm”Çoc¦FÅtU-k×iBo5wU¹XËøÁªŠ¿·Eº° BŒ^!_÷…£Á ž)‹’6ÇGKÂ9RbIJ¸Â·Wï¼›”0W«3ï°kõè鵂ÊHÓj,…ÚÑ»ñÄŒ~O`‡/¨ æÕ,~óˆs;b†¤g‰¶ó³a£.ÝHú_;ÒA|\XðŽú”/—ù×T–Õ˜«ÑçƨnÊiÒN>$P7´“ˆÀPb/ߎ=wùòô’°vØPbµ=l5ÉŒBb´éj=‡O:5(sJ¸Ú&rEÞˆžÇ_±Ÿ ü†ÏÖ(xiŒ Ë]Y¢¤Î”Æ`ŒÔáè(%‘¹!”Ê?Eæû¯dXâÝJN-ïA@@oF{ ‹€Å6Z `{“§$6Ç%Öৢ­5 Œì~è•`ÚŽ>V³Yð¦åâ6p¨wëUè½Ë—ù¼ˆñÞëÛj=» Ï×E~SüJ)_±¹Z„ßU3ÃmU¯ÂÈj1ûÚ|û±ZÆþûnZÍïfÅ—¢ dÑÂû˜.Ž'Z±[µ^x¿)çÅ¢.«Å~á„QŸÛCîS‚†)ªÜÔ¹2A˜Sé¦6r|T ž×ï-p ë¯Áñ©5)1Óâ^¡X–ÓàUu‚ôñ=xVÝxNݺØðV,VË2Œ5íØ"ŸÞ†§ÔÍêhâažÆÄÇà~ÁÊ5ä´W·eœv^ä‹Huu›¯:îã7!5¡À^ ¢²8&Yù<Þ¿D@Ò¸/x¾.šT7 3lúš Né0¨$ƱS8  ¤ßÃalÉÞ½˜Ã8ÛpÂïGÂÙn—€[É-ñ'bÅÆæ½ïÙ<¾›#Øßì! PŠï2{i»‘îKRÏ1»Dº-0z™Úü¦ÚƨÛÖË ûïŠ5½\¾s’×n(`.Ëüz6ôaSf. 5“¡ÁøâQ?È#Ç!È'åÀàNfRÂX_—<Þ¤’¶îd&ugƒ&•pÖÖ$7·`j«- c:[r‰-Iꎟ2¶‰3·éµ/w´»÷„ÅDxó‘ت×>˜˜6ƒt–“UììéYPnŽ…ÀT·£îIÞ×=xB{?»†Wïö±{û{šÍ]aº[Ûo³Œ!ÔîVŒ]2i ß6„„gÑxãÆo“à„wÇ!¨FÃlJ<›ð6“ %5þ¢Ï&h¸W`TBÈ4l2¤˜Çs !™¥|ƒ ¢“XäïDņ–EæLŒ‚×c<ºNh™VËeQßU‹›P‚¦á=¶Ÿ*)X•b;“äWAŸjŽ `,Áj‘B'Ö$axsŸéŒà%1%L}œ. ˆõTž€) ÃÂú†]‹Ù‰سQÎÃãµ2;° K’½.5ªÖ+Ÿ¿ã°òöUÙ|ÝÖ˜áù:Žžb%#Ÿ•¿7á“ý §XdhuàÕ÷o®^#ΚëÛö€™ìöïá@Q9ú%òìû—2.ö㲚6óÈ~(qãú‡ÎsÀ=c>Ý̧:¬[FÃÍçr6N4±.Òß½xÀ7ü°C&°Ä&ØKE‰Ö›[ÙØww5iÂŽ`tåÊߪñãa­ñX˜ÒÑs,ŸQô4«rºžåËð>õgU:f»ø[æ­Ÿïê˜ï>ãݬÍA#=ðî¶viy& MîOFñv5ñNøt%Ñ+Àj©ÍtkêÑŸ™Þ0í±9í]ÂÚܬn8¦ˆjpJÏ9&!2K{O6‚6²Ùð¥^½»[)CÓ;¢\Zߨâ!þê^á “¯böU‡”쮪ëòzÓ¼ULÔÂÆÇƺš¡¹.f6É^+ìò… ÙwLcÙÔ,¼°±7Vïß³‚/ˆé.4—Ùxï@ÙJ!É!–ºMÁ%ÏŠµ)¹d[ ;äxÞܧ¤h]X\öÞ/ìr}3؈`®Ð$ ”%&Ö9uXôº© ìJI1Y!Sÿ2­`G«è4Ú³íýü€†å ¾CÕvºÔVçH¼AGÕ§L¾.¢[×M‰w6»ÜðpÁÿæþ›*q<Éï•Ëèï>ß–ÓÛµÀ³‰*,`YLþ9Ê‘\'œ3{”¶]¾•'¾|ëüÅÔË·É"Õ ¼oh÷\$^9Ä6`„›n°XXN4éÓ_À?>Ä™ð!‡®À™&²löVÜ Xá»UÄüe|ð3áCœ §Q‘Sh«8/"ÎÄ‹ˆ3ñ"â|¼ˆ</"ÏÄ‹È3ñ"R œÂf’‘&£IÿEüŠÙõ(XÄÕˆ¶%2N|S,ªUsXÚÆû ÃÐQêÖ Ï£©¸—Aô¹ qáöR“$ç+u¾ï?cK›«–ŸÇø¯í¡ñ¬ü6é?\tùRŸ×kÈû?âè|Ú€âY1‡´©~:ˆu))žꚇ î£î‘ÿf&÷Gº *3ì •Ú¹Æ èæa¤Ë©O8¿=Ôõ×Óå`ÝoÂÈ`˜²”h#Ïìžh˜ßíö„ómáî7aD¸’‰Å/zÌt¾ÄãKÌޕ鞈X2bÉÈŽ=1;¯g„?Þ„ŽÙx÷õ%'aä||‰<_"ÏÅ—´ Wî zOd¿»@¯"–z0èMKª½#£Ç9®÷h?yyuñpSµ endstream endobj 1959 0 obj << /Length 3470 /Filter /FlateDecode >> stream xÚí[[ÛÆ~ß_¡—jÑsçL€<$iÜ8lwwuüÀ•¸IÜ”Ýõ¯ï9sáMÔ®.k;Eû`“ ‡ç~¾sf–LÞOÈäïÄ_¿¿¾xþ‚›‰ŽRbr};¡\Ç á¥eL9\/&o£×›éŒIå›»mýÌÝ×ËÌÝÜ«U1e2ú˜oÞ»¡»´L×Y••{®–Åvµp÷7þµÞš§uæ‡ÓÍ"|#¯ót•ÊßLß]ÿ<‘±I’ÉŒš˜Rîè©‹:]¹éÙ¦.ó¬Â™Ï_HÑáDˆ˜3lÚW¾s38së)œ¡cBÔ„Çš7é7Bˆ›ÇtgžŒ©ÂBÔ/ÔšŠ¹á“Yg¥ºès;/Ö :d–rΣWÿÂU.~¼¾øã‚ÂÊdB'LëX9QJÅŒ&“ùúâí;2YÀ?O|AO>Ú©ë ‹2¶š\]ücD‡ÌÐXj·¡ÚQtùÓÕtÆ 1Ñ·Ž$a¥;£BņH¸!±‘žüÍv}“•n^qXXm×›1I'DÅ¿ˆ¤Ì5=I¿²Œ ­I`ìÕt¦4×C>96àó®È7­™¥5¦XžIÎIô¿´«6“ÄÔ¡ÐÞÎP'$&Ò­ãÝîÍõ¥—6éÛ5*Õ é-RµŒ¾ñ3i×—E¬Ef‚X(ÑÑåt–D?Mg ¯«‘ÕAJÚˆðÎ_aq¦#únDLÇœ7t °‰æ 4´pqoé¢w‘tÚ`‰ˆ輧´,Óû¾Ñ•.²„аÈçàë3¥ }LœÇ\ЧP¬D…WÉÕ›©aÑw—W?>½fFb1%àœ'qÓû"O@.Fö¹yÄ„ˆ5³vÆ>hMÁ©^“XH—">¢¿*ê,8_Zw½ÏÝswù˜¯VÃÀº©òEV6yÄûr¶¾«ï§JFÏÂüyº­üKïèÙ*[Cñ¯,Ó)#ч)•QÖÃ([Nˆ·^`¯IˆäÃ@0³­Áõ£ÙQP±×> 9éj‹Îcu1î;,‰!gL¤C†ëˆÃt‰+A¤VÉ¡¾cžÔwˆ„¬ÃOã¦ï;äbxŸ›s}TFbi5'® 8«ØÖ§­Ö?–E0°æý2û  A\9ýo‚, @Bˆ'ÀX¸kâéÿ1ÖgÅX’ñþ=ARÇ•8ãÿÕ8‹ m“«½ŠÞ•}1œ%)‹¥O¡X‰+ñUqÖIÜŒâ¬7Ÿ gõL 5…ê)ÈW„ t’ˆ=ØÀ@¤×  ’:'r&1IÜJ"Öú†ˆø,ú>…›q}w¹yj}ï2 á+á £éH:IhéÀÐcÓÁdæÆf*f‰G;”Ž1L1oÌë³Â÷¿0!ìO"!Ü«‚uÑ¥ fb*|"½]¾üáÕõ/¿I8ÿGskÚØ•T>u§îUT‰µÉ¬ºËæ9΢¬²ºZnôYeùa@„z«„ÒlôPÀú•àeà¢!¸(ó÷ù&€âu ÌýÛ–‚M?5\Ÿ¿P]‡Ÿ1°S¡6r¯¸7Ë4pÝ÷~€z´ wߢ¤ ü9dä*Hz±-› !¯$Uç…ó®~ uîƒSc#|Êz3…àUTU~³òËHË<…§ê9$TZz_õY¬>}»üPÄZ”· 9šH Š… ¨D¢ÂÃ%R'ºÔù&¬‰è£Ò˜ `Áq¡¼÷%¦Mœ\ˆZ«k }W†CÞTLySÿ<;Ž5ÈϺË«G¾d“Æ9_j,j4¿sÉc"ÔùRä\«¾¯Þ„Ô¾=Î@ÏO"Èq¼*À¸%Äóù4‚OþéøKTLÔSð—h›8züù i'’ì‹(œcu|@H±°s7dHpiE‡Ã} r 0¤uq2˜ôv&¥j}6MiÔF¬Ýl#5—ú+%›´ë1v˜µ@Å L3(ä¼Zè(Ó¬-ÌNÞå[ùB=S ½Ëwì;„Oe_§¯!µ•»EŠÅ"A\u™u6ý¯ä ¼Gú_û[v›nWuÇ2Ç2»†9S€„ˆ{Ußà’º‚zŠó?‹µ8ø¨gSŽyÂôE÷rƒë¤u~“¯òú~Ì¡¡Þ20ÓPÁýX–E‰Ÿ$JVÝW¹mi·ŒÃy•°,*?ôåq¸ÌvnlóÞ½áŸø›m•ãП|—•·E¹¶uEÀ!ÚÕ6nf~ëf"’r ÛQÛkšÌ‹²Ìª»b³°È‹Ó$*îj)€¸*÷l¥Š7sª¬Iê©õï&ÖÀNÉŽ††¦€óÛŠp³8ò»`EZí~—>ö]ðÑ6cpv ÒÄú}ØqAAXŠ¢iGaï:†´(åS9Fò°cmvÚ ’îÛ@™ÕÛrcÌ&¸õYªz%DaŒ@„(Ž_ì,0KpåVbŒ S è†F¬%S«=jh´,*»-AŒ¡·â¯·ÛÍëŽÔú¾~Ê›À°ÊÜÈǼ^º9~Q(fò lÂïwá6ÅŒÕØ„*¼Ï;Œàg,±ûC{g§Ù;'4z±-1_­‹2C±ÄWW¨‘mN`|Üô) Ä„Ë/”¨è'…¼rtºÍF¸¹kÁ<å^Ö®Þ„›yj÷S3î…´ÄÝIßdð19ˆ¢·S[ËÖPJJk:õfw)^Xt5_nK7‚b\ùXÏ'U ŽíîIÝÌiщ起>$÷4¡[ÜÇF¬»ôà¶Z˜Ò%|cõªLkÝD2È™»«@ÀÂm›¤/î°yÈ‚®G¾“’~d<Áź¡¤‘ùã"€Ñ–Ôv¶CQM­³t’\eU58:V/·q½ß€.k(S2@4—Ùª…•`Ö¶ßávðÁ€ÇJ–¤×³=§ÉÑ£d/,ÛÇK"íÙ€—uZþ>F3Ti<é¢2Ê‹~]"0ÔvüðbጠÔú94‘ÌŽ5X!ù2µrNw’ÙlxC<†rÖE.ËWUóÜ)Yð ’†ÁfSu؇o<8 Ê5K1ì>ãVž‹–€BWÅü÷ÊÝ»0i¢*ÿ”g¸Ùf±×MT<úÍYGï³ò8"8±ã©€z]¨¦ýÔ+åX€îx·táîVùïègÙêÞ=/²9Ôy.ݘ§ãB¸ ]ÛÍ ݦ2\7µzªµ´éI`þnW¬VÙ*¯Ö{ ™í<{°[çk?þÖ £„•5Þ\bÝ 9¨ä›Ñîd·ãN|î|á]{Œ©ÓS°Ç˜$€sÛç·wë-êïlËÿöÞ= ƒxµ§‚ñVÚLˆC©»ÌS[•9¤o¯uXdÔTtðh»Õa¹ÁT»gY™{Œ´–ñpÏ jpÍÔ{:9§i¦ ”`n%©õxÓlw“/Qüä‚ >Ù­PÆ¥Ê@ ' à½fæ F)žC¡n%ÅÌÁe…ˆ•jŒs*‘ÝU5Å!Æ)iü:å àHÄG €j!ÓxË›Anæ ¤Âê nΓJs(8¶'š@ ÝCò8Üœ TÊÃt˜ÎØüÎ&Îô†ŽâøS–D…S–$d´™ûÁ*[es÷1xjËâüg;Õµ³y7>Ë푹{×s‚›NZ>Χ¥¢X¼aÂí?ÛÅ0ü¼•-ñM+‹âH°HO´g J|1ï&_üØk_ÑrŽ©y×ݹ?˜ÈC™7§„?€´PÊ>ý ?†æOÑ¥Ïê5`×€»•’}[#gâäí¨§a.Q±ú)˜K PªûÌäÛÃÎiÇ‘ÖÔÇÞ<¤ü Xä"±'±ÏbÑÃ80Xô´kÃÝ£§œuã<ÑË[² &†öOU/¶w«C SÝŒ1ì³7]í»²ÀÀô!_dí!ØMØ:ï-°Zµï€yèùõÁ’o¨ýÚ,Û#d´$‚èÕï×nø_ÕK'ÉnYÏÉU€RÝ3lJñ%Â×Ûõ]5vT > stream xÚµ\Ysã¸~Ÿ_¡—TÉ•5‡¸‰­ÊÞÉ$ž#ãIR•Í>Ð=f %zI*^çק €‡(Û’=cˆ£ÑÇ×ÝऋϋtñçW©ÿýþÓ«×?K¾°‰Õ\/>]/W Wb¡3•0ÁŸÖ‹_–XLÔÙ9KÓtùcÙvMyuÆÓå®+Ögç\¥Ë¶®v]Yoéé?©JÏ~ýôW;]d0¶–al)3˜Ùúæ‡wŸ.°+gð—ùøà™%’ÙÐÿO}—~½6QV†ý0†9g™H¤fP0IÊü¦ÞÃb…Á¥o ,±å¶èîÎXº¬›/-µÝ•Ý µUõWË;ª¾Ê·ë»rÝÝ|sv.S¶„Gj(ÚÛbUæUuïß¿)¶ô~wS4UæŸo“oϘZú¾Mùù¦;¿‰cµåÚ÷û/ö*V]Ý´ßàö`»p‰U–v²*¶]“WåÿÊígXã8Äà\°š~EhæË›ºí¨ê¶©WEÛÖ 5lp1Ôråûæô¸‚Wp{Xu›7ùz2òpbý&o‹äìÜX³|»–íÜn ÖuÕ”]¹Ê+zêjÿë&€Â®-š3™.ñ„¥Ñ /¯wÛÎœŸÁ©•Ý=Õ™Р¶“q Lså[«âº£ÒzÊöXYãÉÐñ44O7tv“AB@Ó„Á?µhP$ÃÃÇ?¿šOl¦(Óæw2”õ2„ýá$ðù'\ë¾ô¶7õ®òrÝ9ÆÒ•ï[àn¿­ê2 é»”]K…õœŠ¸®›ê>Nw–®”ßÞVp踘ÄÑ ¨&ÇÔ{Wwø¦;ö¼ %d,Õ·~/"[®ò-U^ù`ªµï¶E6Æ’“ò£ƒ)Ð’ñ4þúþû‡N€iPŸ½4©“s,DrCy[wÃåfƒåž°HPÚÚª#VéŸhNå)ÕЯYã…c•ÃÂüù0™èlr@¤Sñ@AE䛢+ÏÛ¢X8"0Bé›ãÙAy³Cå4佶èÃ8UĠŒ•÷¯Õ»îv×à´kÔï9ªÒò.JI5ނج2¨7§ö/·nlîŸÃib·+?êàé"TßSuf ö§7`3Ť¤“T õqº”ZŽ×"‚³DfâDÎuºÆÍ Ä¦Óe’>&ì—f Ýs饒Ž*Vn+ŽÇ®ƒûŠ`‰é á%²UØ´©×E5~ ¡ªŠªl7Tq‚‚•,1* õ‡ï>A§V½xDÉ®½îÐlÒ˜$¤NWÅmGåÊ$™ðbd_OƒÎMž”(ד¦m½=“s4T çàÕ19ˆîr 0<™:‚œ½öIÉH û‡_ ´‰–¨ptb…¦W6»Í­3´¯~úôê·W —¶` §MÂL¶PZ$€ßjóê—_ÓÅÁ$'Âf‹;×uöUãqV‹ËW'\<^ ²I¦i$Å8Í dúà lePìaëåû‹™…YDŸ¶°ñdÀ°Òã…¾™ÁÁ ©³C @:ŸàŒxjÀ¯Ù²È«×«zs[¿Ï ª(€¨PnërÛ9,›7M~¦•Ãh™X°)¶mIºãéœdU’ö^ÃÅ,=E–%iªN¤çHCÚÔYÍ9z¸WñƒÊà?iʵÔIjãÁ¼ûø—ˇdÅyQ&ô¾sŽÅq¢©’Lˆ£¦‹‹ó˜ý\HãÄ{¤§ŠÝ°\.‹ßvˆÝNÕŽoÔp€ TO³9·Íýã¼µvU7 xYõvÝÆÁ]™KŽpþäÕ® z°A¤—v`³¿øæïâí/GÃ~äÁ³¨Ì>™”2‘<žš‡ÑÊQ%{ Õ°þÊC-n€É Û3¶\pm ñè`Gµ Ø›À½-œ¶ï!"ª&#…úp]qÛR½ þ\矫"_“y‡e]0ž(cv™±$KÍB¡Å¶âÂ.38K#aူ£ \èŒxNS€«Uîôçç"ÂÜ<`T_ã…Ä5ÖÇêŒ,aœGðÝÏïC(uAa‹¨N¿‰K ÀÂ#ñ¦èvÍ6@õÇ´äè;veš% É&E ‚.Ü{JœÓ€ËÞÔª§ñ ±ñ\«Éæ *tJ$QÅ?eâ–žÐæšFBÇ&ðR·ü#þýr>X °àlëÓ  m±t¬x*NÛèXÖP…[±·Ñ§Ã^RVx>w¥Ã¸pp«zÛååvrœ¥Œõ½G…AÊ †¦ÝøÖÄVôzSæWÕ‘¶NB‹xæÍ<ï¤6‘¢äò$åÀë© ‘ WO&é0‚™–ž¬”OÜƆ(@°ðêoBÓ…J¬1.: È H*€a¢'1ch@ò ôZßmêãgJ-ár&5à4‹…ÄJù$\.-¸ù°2;–_`‘pW§,l £S8aÆ ;Ë Ùq`h¤9X®S–Z1Cžêç“’gÀVﯰ^D#’âÁXã‚1XpLzaÇŠð¡®x˜Ç™9è̓ΔÔ2áö´3é ­q€¹#;(¼6á½âÙµEŒ1==kWƒˆ±sžz°Å±@îQŸ fŠàEp’]z ÁO ‹\œ $ìHp€¬Ó >Ü ð'ŸÐÞ‰¹X,žfÇ©8ÜÔ˜—Ð5ü'ñéºæÙI£äi+›(?RŽWv@ÙˆD°CÊ¡»è}x®åȇçZS„HÄßq‡¿ úmw<ÿ)ž½ÿ7âù–âø~ü§¥÷D°¨èTÁÒT6–Ó‡Ðmo÷ÔCgìáDGïŒ=U“~ DMDÅøˆÎXóKSœ-øg p¶à!Ì:ÆÙðq¶Ð‡¸Ö€² -%w`õy@Ûj ô¶ÎÆ@ÛSYD@ÙÒâÂËíš6G†vÐ…ÔEŒPcKÝ(å…»›ru32¢r_¸ï’íçíŽpPVâáp 6 ,Íœb;݆ªKŒ¤‘ÒçŽD lì æ˜Ç#Z–•CàäÃN™Yß;³}69ÆÅ9x.v\êÃj˜ æ Än…ÝË3l#ÕÃx•³"‚<,qï Ã<”Áâñ±j&¤ ¬œ’)ÁŒKJì»Å &¥Èæ ÏtØ~>6º¥ªMÞ5åïΆÚ‚'Oð`Á´põ¹“J%4N ãô0×áý8(Ýøcw$&@“pìÔD›‡” l± ¹à˜ä+r'pãE³pÒžQ2ð³qxß'|MLøB©¼¦p€÷1íÐi1~ÀïT©˜^qO“Ì4<Ó!Ë íñò@Uveá‡hŠ ´ŠW븆š~‹¦q›3.Ë«û6ÌIúvôø€¯Iµì§›£Û¬jwjÊ ¢2ûwXú˜%Ui¢ã{¸ø# xÂúh?í‘WzÅCr„\±k GuòXÝ”DÆÀ–(Ô/xísià×ÃQ8?8Üe’þ&Óåêf秔^R~ƒˆ¯”ò°…R ëÝ O›êø X mKÕzt}»¹ë;Á2 €©Ù^ÚeŒσíÓи5wb{žÓ0ûßßÑ£!ô߶ôJGw©Àå1JïR½ýÇÛ—3hL¨0Ñyê='):¯Ð úÿª¬J4¼³ƒu$g:¨ÓéyÓ•Îà@íp2­âHôR8çÎ?‘Ö¥²—Ù~VÂý¤„iC#ÑõlÄa[5Σ+¤H1ŸqÀ]œÂ’[aÈö÷CP¹íH3Jsp§‡.Ö TÚÌ_èÖ½%Qù.†€cxÊý:s?ǺÏ\^êwyè®Oˆ[­AIÑ_MTk.ß·½’óó gñ‹ë|¹»j‹U‹Q”“±†qŽÀ郉É`}Ÿ>$Ÿ®/æ¶'":“§yö€«OÐn}d9 €²À Î.÷:ι/îç}ì×?ë‘ÔcÊÐÚ±Qþà ׌ЃJaï~KwÍr‡ð:Fým„õ®‰wbóÀ¼Ž’ ¯›Ö2 |8˃ ºA(Ë,8 ÁIx î.ª'ÇŸØŒ,ÁÔÖ,ÖsÞ4lßÛ¾oö«ˆ#/ßüû§gËZÒ`×.ÉÿŒ`ÊÀ/ ‘L€}—?üå^Ëàpܽƒ}\&/±=¢¾xsùéŸþÈ8›ÞwÆÔKlÐúIÕñD¾~-¾ûðñý¿¾êT¼Ÿêï |õ]½ýþâý{h.`NËÝocr½óëN*‡7à¾.‡˜j,ã’Ãò6±Ö<'û$ñªd¬·#o–î%ŠÍíÙ,ɲ—ت0e&Û{÷„í1;ÉvïâØD÷òw`§¨Ë^dŸ†Ë·yqñ㬽;h÷À`f2|.³‡)ÙvîVyL»âï v01ª) øí@õÎU·ã¨oá:ð®~´L¯'ŒaÀ4 ÊXÝÔ6Ì&¥Ÿ –å'Ī€Ÿ¥»ƒøk¯ü»=~v¯‡1\… Û8ØÐôßø{¡XWà?ÀªüÚßž³Ñç@Œkí£ñifeüÌ‚[æ"Àˆ`Ü$ØH“`U¸eŒµ±¹‡XØ%ÆSÕw¡è56Säë\p4Ï(Ÿ€! ‹1”£ó÷×c&±  °Ę̂äYù{wŸKÒ@©dO5àªÇ ÿ1xtPh°ä½aS`t3Œfø5&&vë“3&$gŽ»û—âµÆÇ™Ô,Ñ€œŸMRLΊT<—¤äpÎú@²*ƒ â‹åv]®‚G´w+z dæÉ!…""CUݬÉ`82Ï……q±ÂC‘:àŠ,UC†C¶3Xôk‹<…uCvÆç§Esö˜%²ÿ†óëòs®Þô[•y@f-á¬AjÜ ŸcW”»c…#q«žŽÌÙéžG&壞 Lþûã.75ÙßñÐÜžÍ9.ô1'?{2Ú¼ÀNÞáVf¼Ó):ŸF‰0%½‡GÓÇM´“h¢¥hâ|,dðv#ûfcHͦï!,Œ‘lfŒÛ÷ø~R‚™EH’ceøXÍ„+aLû«`Ìô½F¸»œ~ƒ d28àY(2ð¡Ág²:QB=çx3p¡H„8çSÀŠ#ü7 …öø«ÐüÈDº”2 ’gºOtN@¡‚B{ (dÌ8ñx4ZçÄH-€H˜h|®¹0òd2Ë”a¶í©âñŸñ::ü7¨Œý#ö¶³øÏMÞÿ?ç#à1hÂŒGƒR^ZýE‡Á± endstream endobj 1910 0 obj << /Type /ObjStm /N 100 /First 1003 /Length 2894 /Filter /FlateDecode >> stream xÚ½[ko\·ý®_ÁɇrÉyðQœj\¸¶`AÛÄ(GhŒR É@Ú_ßs¸¢‰´Rë«8XÞ]Þááp8sfHåÖrH!·&!›³¡Að,W6<¸6J(øZ6ZèÖØè!§ÊNÒ$•=´ E•2;…¾Ðñº÷Ζ…\e´ØÅ9R‡€ÎZ¯A²ŒV "N@xM”â{JA\ÚZ¤p`’š ñcu ¥à·Ú‰N8'cWü?°ö”ƒt‚ëR‚&θçT9åŽÉ©&ѳõ:¾³ 55¶9ýéèôûwÞn¾Ý<ß|ó}{›×GïÏÃ÷šs,0oŽÐšÖ Ó³EÉÝž†'OÂæ0lþtòæ$lž…/Î>ýÈxýÃÉqô˜5ú—᫯öðïóe¯;1˜5|I5V,µy‹&íV@Ï¿yùæÅ_äô×ËáÑ(0”‰£j,°ü‡àÈKâÀN‰0*¬Œb`¥ OE«r+?¿úzIE”˜`õZ$Úð¿ÓT$zÖ]šPYRSÀ†½bÛÃVØdQM tF¯Á#G‡³³R#üct·õ¡0I„+µèp6œ~b˜3‹ðé·ÂxñúÛÃLJ“@”ºD`)Åï¹ ÁËEˆzD,ÒŒÂ{4°•Û^kY€¾`7b3ôAR° ®šzle…ù«Âò¥aKPó NŠ\ªx˺ËeQïd•þß/Xop“u'eWÂTb:h*1/‘ Ó`!¾ÆRXÇî5‰$X†H"Aª×[ °q¸C,vc"±(»ä›j] ¨[úsf¤°X™žËíúåç †t}x!SÌXÜ ‚ÈÉ$Ÿ ·ÿþÃùQ<=ùttþÇ, B‘ #$'¤Ÿ‚&´ÂýP>ýúþ3‘üÞS6&]IA#è1°=H…©,ÛÉcä7|êÉHˆ6ýÛß–U+øâñ§ßÞÙ¼5 ˆ|Á'ù}½aÀ” ÚåþÞµaßW¦‘iÄC{cú ’a× ÙÇÞû'ÇçCsûÈ–,çíkûH˜,_ÈØGvâm>—û¡¼ƒàÓO‹Vª™dÞT2¤ýš1ÇiMé}°wyˆ¢<ÒÄàÈ?Á?‡·¯¶ЄLNlÂ`°«ÙwÁx„Xc˜|I¼rs7á¹P೶5N”¸5„iöD€ìí ºR,ï^ð³ò‡6­#³\§k11E`óKšåâ"Èn‹Û$"»k¿ÂÑò¸~± ÇcÔ(™çgÞ"´Øæ¦d\ÒñèÿsõÃÛ«×;Î-k:öç=½ç9(Aµú s¤ˆÿBÃÚÄzÄBÃ̓¨ëõ¥ûœú¤ô»ú¾ûŒúÏ|½Ì\¼Ì\¼Ì\¼Ì\¼Ì,¿\¾5³ü2³ü2³ü:³ü:%×)¹NÉuJ®Sr’ë”\§ä:%·)¹MÉmJnSr›’۔ܦä6%·)¹MÉ}JîSrŸ’û”ܧä>%÷)¹OÉ}Jî[ÉX£4y6dÑc¶q ®¡¨DÅ:g^.ä1°áy÷…©¥“‰4‹Ž®#iÉã†@Q<ßqKdÙ›cà Zž q|ÜÐ] ÓùQn‚75$dõh¯pà Ҳ µÈà,’6ï<ÿ¼=‰?xúzÉñéz…µR ˆd¤¥Ø°Ó½á¹¬1¾E–½¤HË»ŒMñ\/éÜ~¨tvòñÅÉû%ï/–ÈÂë%X!€wX˜Ïž{_C€d¹Êšx=‹Jn4¢ðZÿ8ywlRÖ8âd¯2¼+ˆŒ×à<€‡/pÃ÷É×1&x‚ÐàpÑãê&+Àüû­Ø'·/Äó—û¯à™uÙ" Àú¸o^ÇÝ^ãàâüJÊ`eNq\×:’‹\ˆÉï¼Îú|ñ½‰ÄsØ#dcQ€’ÏðÝoWÄáÂ41Ó¨#:ð/„x?Ãt³ñZ×3ŠªXx8mžôXf±ÓI{cº«¶ø82vªVþé³qÞct:nídYeI¤¥qN ú™÷‰Èi¢÷ÅíÿP ÷† endstream endobj 2060 0 obj << /Length 4020 /Filter /FlateDecode >> stream xÚ½[Ksã6¾Ï¯Ðe«äÚ1OLÕ’I6;Ùyd=N¶j“(‰¶Y¡H…”ÆãüúíFƒOÓ–9rå`A Ñº¿þñÅõ‚/¾ÁÃó›Ëÿø§ŠŽÅQ¤—W æ¸XDÎ0¡Äâr³øeyy“žKÉ—Y±OÏ„Y^§|:“f™TY²ÊÓúì·Ë iÎü™E…}4™‹ï¡'Í{=ÙˆY /©‹÷?^|øoh€d &#æ⸩þr^_šIaº®^xû×tõî›·^ÿû±¾”dÒžÒ—n‡u¼/¨odS›ÜÑ&y]Rj¦y“þʹ,Ò eå†oÒ«3uù¾?óù¦}q.y̬֋sÁYlbêã6Ës¨nø²ÜߤÕmV§”]…ç®*q=}Ê6麌ŽE šÅФoêç3!DèÐZ”{J¤’Ð˾¤§xIO:¯è©è‘T¡÷}•&{?J, ír6Ða§Ë¨¯z>”îÛô*¨Zø„Rb##ýkÇLÔ®ø¯ÎÎh”Ó7¨ãu¹Ýåé>Gú^ïË*û3ÙgeúyŠhç¡Ÿ€o lÚYey¶¿›ÎhfcÕ“NÛxYgÅäQJ/÷7>a–×7‡ŠÊHâmZì)ŸÕT%¡ì.©öÎ f–W£æ¯órÕ|³MöUö™Ò¨¡ÛlC+$H;XmmwÚ:˜ó ˜ªe•×¡àŠž¾#míÈvùwýåH•Vw£¯uZáLÀ 3 m[~Uæy‰-Þv=îp˜5½‡î½ÎX Á”j·ÿ»ŸÞýøqbj”`¢3¸|½”–Ì7TBÖNtŽ …ž½Ò|Št ’5Sˆry!aº…1(üs¶=lCõ*)êO¨´ª“F¬9,‰u’ÃC.Û§t†§šôi,.P3­*؇(8JœI~Wgaû%EØ0›Iž§ySL•¾ds^¤y·Í¡Y”3ÙÂF«pIÖ ·,eo§Î²Ê,zkeß¼~ù—®}pû>´­aFªñP¶Iõ{=½F”ío_¡4_¾ÁE¯xX¦ŠûmöäPéø¼îM`AE(ó¼q ð‘4OùØ.*Æ»MðJøúØÅhã}¦¼Ù¥ÕþŽrõMyÈ7”¾)óÍÌÙߣA;\£?~wñηóÝå‹?^àÊà `)fRº…1šD´Xo_üò_là%¬r¦b·¸õU· É"a¾øøâ?»†º³‚Å‚ZŠ %ÒàûÇ´âÙ¨QÚüÙ’,ví\½}óñòç¯/îPJÅ\ô ”ªŒŽïãëýtñt †cÌpmÐúÀÍüjæ˜aFÛæU®aÊ5Ïç+¶—oþ÷Ý}­*®A«òÔª¸µÊ“ôú÷, ¥«'e¯ÄL$ªbƹ:2ê šx–QÇŽIRfºsÀ™ÒZæQLš ÁÎû˜•lN‚ÎË)psyóÞ–ô¼IÎ<&ç‡% =ÖàûÀ…e"ÙPYp¼þu;a¾Á:˜FÔAuòÃfpý×izdbÆÞõãaU§ë€·¬ZBX§™è‰ö–ð~0Üž*z,Ï]Y× ˜P^ï¢1S¥0GZÚ–XŽªÁç¡_%¡)hëCžT”_'MñË›P°ÉjPÇ U{@ß=ZjF8Ô|9´i}Ïw‰ø¨órL‹ÖV¼’ÕÁTP¬2€Ã  ÷>–¾?ÂÒÄ%uvíc1ÿe:(ò»&à °mÀª 1qU®Óºnvö|ÅÀÎ6=›ŠÁüô6Y ëKt&›ËyÝÅ °âÓIAo¯Bð×$…¨Ô@6¿jüêÕ\™¢.0š±4ŒI§ÁFˆ—ò¥¢$aH`LA©¼ É2@ÕZDKÜÃø&+v‡=%›¢¶­›²¯V)ôtôºÛ˜ÛÝøØÔð*Ø)Ý(Ž®ž{ ]5‰j€ZŠ·r8lwõŒ2â·Ð'3Ó1 1‘‰Á±bKл‰Ú°ðo!öê¯TI?î²D3 Jø"ɽI.™ÖñP²Öe±¼bVªî鈷€~"ðœjLy:žY‘a .gCž‰$Í?‡íÊ“wF£‹ÏQ ŒE¢ÙÆvšïÉ`ù…âÐç‹áBéŒëÄíò J¨¥·fR‹`·°$Y£aò‚Bns ¨ëPgX¥‹ !+Ö  ±×,‘AøIK²itu7sK§Xäı˜{ˆ‘5øfúkÙ¯V ŠÈA¦ È]«’í¡ÈÖMj=‹ZÁм& O¬Uà°À“e”ôƒ®)„g•þqÈ`l.úÄøG@l¢kÊ$`à@šuŒkë[Âðî‰ "*Þº›Æâ¨WA9מ´«HeePq€„é"θ¹Á†ä#’AÆzO¹-2ÁUú+æÀšE³Ã‹iFÝ9XNa‡ñÿ1 *,LðZjŽõ1ä™D2HB{±ý2‡†‚¸Mr_À ©f:–R0P6Xé·#e’ªJîÎ"³DÈfÁ f`ÊjÄÎóDÍ=þhz§iΙ™¯’Á1W4RÉ“ƒkA: ¯‚)Üq^+àüÉ|Ñs’9kÇ$ž äÐ!’ÇX_´ÐžÐÕeƒú“=•<¾ˆÄiNpÄ”=((±¨ö- k{*kY)Š…} |€»0|„wL±Wƒ«þdyýÉ°ò’Þ¤.‘òêĿ%‘´‚ yȇÍÃÁ4ÅDEäQðßñƈÞLl1hEF°zõúxl©#î]º@@cAˆ{0Ù{0Oq0¨WKE𠽟‡z J[ÐéV€Üðañ"×Zå>|ó(ùÓpŸ²$9‚pÙžDnDBˆBû'„­Çû§Å-x:6…[”e¾š [Ò+P8‚ÎUÌ}hßc€±¨£Š1÷ŽÙøÊ0ˆ«ÇdÃLnIhÜEñðÊ3ÊŒ' Åò±5<ëtO o¤â@3cÂ)Mû[6»‹—»´ÚöI7ÂQÂ(BK=žY4sF i\ç‡MJß"&»E,k*Å3¨v &»ƒ‡PÖ.›ЎΤ»%(··’§yn§^”Fê$掺ÖT¤ÿ"ž;:Êskm4Šg¡ÖÖßkŒð¦ûÕû™4øì˜i120¸ ­aaøק`î[ÑÜœNB“×.SˆˆÛÊ"ÔèãB€>‘ë(õ„ïƒ`^¶4›hÄ0+Ô¸‘$b_†i…K£˜ŽžCã˜0â$­³ÕÇPCFtÁ„Ô‘-ãVRMOƒõœóåë–Ù«qç¸saÁ„ ·ìù6ÿô…%ÀÞÖCnrO‹gº+&YAâ…£>Dö™Þ4W‡š»k¾Pœ·¤Š¿ª%TGÁøÑz &´œ„Ihðl¬rPGòMPÖù¼ë: ÊØñÚà6ñj ¢e @ø”{1.jÉèGXÑñ©š‰O9Tsæï+â;)žc„ñÇG86›ˆžn¢«s8£¸Òð_d|åÙÿ‚ØN÷JñÙQVT|ÖFsȯ^Êh¨†OŠú A‡jʘÀ!nÒúíÂ3Çþ‹«Ñ½‚ð~^Ìk­§Uš°ìë‹cl„1yÐis8lê&ûsPk$ÕòC(+{Š)®ª¯ 6ÄŽrn²yŽ1|,-Uˆ¬P1ú8¨ŠŠrÓToߢådÕ3XÚñ·®áoço âR?Ù¿+Þ¿gGóŠ!¬§Ø¡Iž×Ä™Í@ÐŽ;v(i˜äñBB_ðù A[l}4€-E0¨§#ЀŽä—[# èÕ‘»B€þ|psúe¤˜ÓâødzÜ#rªž1r AdÃ¥ø¢NV©»U oÛ‹Ë1‘ŸXFw‡æ©Êà©ñ‘Ûd:rÌñèt¥­`:Žfêj’rTF0ÀnC{‚++›àª9¶½Z…e>bèÞa`°ÉÖ>ñú }Û@KäÁƒÞ}½¦>êlí#`Ñx¿ñ^ÇÃûßXâñh¿3ï%&"­¬˜ë“U|œ—1 Tø@8øÒè÷º6Ô’5æén¹Ìø`Ñòvöx£–ÞC²›ƒ$ÛâOY¼*Û.HÝ#v`‰rÆ#Õ;œW–î:dšäBn<ômë»UàDÝè2}¸­G¡QH„{0~Å`y•%Å5]iÃ<^q£”_Äý/A²• Ò^2ür¸ö ä!´.3FTµ«Lv07œWÀg4©}9»]zo4”Ý)†«cF×?ð¦Z†aøxWk³¼$ö$6K(¤DøÅQlèP?ÆQ§¤ÖM¨> B™N(3R¹¡ýË=eÚX¿ ý6·(1“no²õM#W=Iž„û|0çtõ)D®Ùø·Hí/§&™5I—¼ïk2kߎn=‹œ Ìð6y¤ÍLÊlp‰qð³©ÞW¢Ïâ¹ÿ¡2hâÈXЧ´n¢ÞT÷€ž–"Ü8¥ß)Ñ›’žúJ¡vký1ÙWî]©Åwã ¥Ô`AM÷šk/L6WzHìÁÂ8ñbÎB¾Õõ®"ä•/U :¢sžQÂ#*ù-eWýNɵ'×9š=Ì”@:š‚þèR®kù$Lúk§ðü%‹þÉtô'ïóýÖ5ëyJÌ?à3š¹q¼›¬%Ÿ¼q…çu•m†%½ù^õAµx†‰Ôâ·SO-~÷ŽÔRw¿4x„£b÷'°ÛóÂIfak„u¶ˆ¶ƒOÀãÿ\´^ endstream endobj 2103 0 obj << /Length 3600 /Filter /FlateDecode >> stream xÚí[[sܶ~÷¯Ø—ÎP­Åw23~pœKíZ’k9“¶I¸»”Äf—THnå×÷ðºÜÕr¥jÒNlbÀÎå;¨`v= fß¼Üó‹O/>ûZD³Ð´–³OW3&Bßb¦Cå3ÁfŸ–³ï½¯O˜òòâäTHá•÷ëuRéJoc9)_ÂO­½ôêäÇOï`‚ÀgðOÍ œ©þññ˜OÝù‚À7‘†>v¦·oÎ?½ÿ!P‹àæÆ¢ÅVª˜/#S¿øŠÛ/ÏV÷´Ðê&¡Â*?áÊ»K Zñm\TÔ_õzJïrq³qbZ¹~¥rZRóu’%E\%Ë—¸°Ù)ÓÊ7R@!ð#ÑJr­¸KËÄU0yG¤ñ(±!¯›|%ÜôV6,,òõí*©Ü/')kIíbKz6’ú$i(}nd_ÐF+LȼMÖÑ ¬¨õßž9Œ¢@·ÜRϾ=ûpIÝzòá‡QT÷ŠW',ðîð¿ø¾¤9n‹×ðKºL\• ­´&ä í ó¬Àø‹†ý‰˜ôʼ~3®¦Ô)SÆÃþ¦L8/ú’…­ÓÎÇÙrÚ2¸ö#ÃŽÐ;Ô* ÍŸðÀû÷5hP¯])¹B‹ºJ•O§û;"Ô`g.2÷nV÷nä|0CœÅ«û²VÂÛ›¸L¬_}zñó ”1˜±ÖEÁ3Ñl±~ñýÁl ï`DÎîl×5x—Ð…€òjvùâï#þŽËÈ7ÆÌ´d>-÷oâ!øQØØÞ»‹/öí; }6öŠdexZC“½ÊWÎw¥ÙµÛ“¸€S¨’ÂíQy“oVK*ÏÝkËä‡ àYâªól0ìM^VŸ÷VX?áÄ$C×æGBÓ×›õm9r þÌ„3Í¥¯à´÷œ÷u´ç˜ŠüPÓH¢ÖôOÎyðþîE­Öžøx"ïâÄún܇hÕì5†î’‡KC›'‡ƒçÊ%Ï›‹÷cr0Ð~˜‚G¾Ÿâ\„à¾0ÇÈqöÅû‹7Ô+Ü:ôyPˆvI$á-¦ŸB")9Ì”¦í’èT0éë@÷½]\ ±…ÒK3BàL¯Éd¡f‘ERÞæÙ’¬ª¬#Äç{kqv¾3OË*]¸®à3¦ÿ’žóU¾øɽ†3Ý/ Tz‡±êºH—ý×!jB\.ó¢ôON%ãÞÛzÜ̾ÞôÆÈôÅ‚–¸D¡½Ÿ7qV¥UŠ¡— CÐêËu¼Z!ÖÂU3jÎ]Mï­\cNM¿Ár“"ï÷ßO…,¯¨ež$UuüœßSÚ=¨Ø”0¿ P½¸ˆÜ‘˜mF§!ÑiU; Õ=x!5Ä‚&2ã\£çîºõ6ˆ øT0ˆURq',D ß´-TJ°bnÖóºO ŸåªŒ±[{xÔÅu€§«x¾J¨#X•W¸Ó»ï4¹4ãÃë{ƒž†t¢êD¤<·Fîõ1‹°À\÷¥Å>ë4Û”ÔÄŽÌ7 ÕÀëVÝô}¸m~ƒÊˆkŠi!dgX*oâÛ„ÚîÒÕŠ*ç =—nªdIí ¹”HD ¶GlÙè«»¨~*²E²Ñ„Æø¢Ýé]àb„?l0ŽØ7ˆ[²õ Ö®L¾Ýþ0µ[´ $-–æõ-<·ê[ÜiUY Æ†Ì h_ò ë.MÑê•ô®Š|%UãÙC‰ŠöÃÇø!`Éaà¹^ó"E7!‹"»FHÑ\ɪ¼ugf9_Ùó*§t fŸw¤rKè2ôùc¾3&ôeÝ6¢5ç¶15snÛúlpàõa­hÚ›*ͳÏ:ÚóV€`lÒ¤¬=3ûÔ:òU؃Pí‘Ÿr’+‡'I…Ú6±l·ž!SÛ5jj›WœéÒ„ „Ž)/¾kúvM=cšº|µYî4^ñ¶‹ÁÜC–¼gWOiN {ÅŽÚVxDô>i9‘l刃ÀçÂJSR‡ºÒ½!:À·›Ð¯ÙÍnßíÑe7qI=cz¸³ü½îåYíd: E³kGM~te ‚E•;r À²ŸlöŒk˜âv”3§¡ìÖ„†5d³‡ËÎÑ£g“½ÕÀƒEwì e-ú.èu*2z^.â÷¯?`DyÞÆƬ¿s¸fSºBLèÄÄé:Cÿw^ô0 õ$3ÀAš.\ÀÑ¥"R‡ÖQWõ†(âì'WDSŠË1 è°L8ò…ùHÜ4¨µxÔ‚ü§ekìîÔ$Î>¼¥ìñz“¥‹NÓ9¶ÖfÔœ•É‚îRƒ¥hFÄm”²1l[g·©;[»’¼Š;O€JÈ!°Aªƒ ”éØ©Ëél‡¦ÒtØ ‡ày—NOCo“Aâž]×5uø¯£…êÁ!²!‰šc |gQDïa¡5ô·Ã*U×øý fB½wjnË8#>;D'þœN±0òÃ6›¿üçÙäL³¢Eà““r`q2shùù$Ìa½eâ6nž8檉3ØaÀ*ÜB¹C~ŠÒ™Õ&i}Ñ$¹´ò3ÛTÄ.qìïBቅÏš`ïlãïlŠ p ÷¹éÏ5Œœó[ßV¸ó: ›èÜ× ×&Êæ"e´/îÙ3tLËÑ;KÝ틤Jù 1Ùè1 w£'¸]¤Ä92÷»k³ØpY ¥Øܹ›ÀF¼Ȩ¸¶áûl%îom™6;)©¯ÍKWø•þ²)ýHŽŠ‹*Ú­\T˜ß·®;â€Ù€"'œÛxñS|@ö‘ê¶gžé͸³ÐØ;=½Ø;ÞÄY‹4’Šøs˜¸Ð÷8Ÿ6—<Ü £ÎÝÇöW!î6nûsƒ$.Vi{ÿÖû¤e\c˜\ÅÙƒ$™Þ©{=¤Rö"ðö¢ãrøÅEù¹}ôzÏÚÞ'ÕˆsezªvIérd5 ¬ƒ7N˜M·—ˆ:©ŠZÓ¬Û%GªKÂÇÖeEµ÷æâìŒJCPªÆA)7 jô=Ýwô~6 "9Le(º6­÷áÌî=Ó¦IÐqÖ¼ERmŠæ$»žÏÑ[nwS¥Ù˜?dÜØïøjaáí¯*@¨LkŠóGx!À»hÉp§îö€¶'€©¹~ŠIaÁtÒ¯ÏǾhà€ªZ4í°A=4 yQñËç\ﹲ垦f‰p\üÐqôk«qó ¸<Þ£Ô6tÒ¼ÞøüiÀ'©úgSý»òðÜ4lŸ0Ó(òÀAÿž8xžV»x‡¿¶ä¶ô"(4ÝÏO‚‘Ù"Kº>¬¶ÑáÞ ³ ¡NêHur‘–h§ ÆÏs{ó$¤»áBP> 5›ÛÛ¤˜çËàw*ê»M¨X§YºÞ¬©¶á‰»¥·Jb÷eôY¦¨K‹Î±íˆ2&¤Z÷s ÄWü9œ]`ÂǤ™€»¸À‘Bop¼ÿòà­å÷¾Ž’}&Þè Øþri\ÍíwmúÎI[!öcwF)Àh0„°ÇÄ7ŽÔ€ ro4ö/SSó ¥u¦âöSk¯Í}¯ òñÌ‘ ûñÒ;㟟1çÚÅ‘Šüe8¸€#e‘€§~Ž”áMyB’ô¨¥’¤½¥ï`IY—GO¤Yh£‚f¦Ï¸`C—%Åß6<`Ïš%ÅJ X×|ÖÐVvÞp$)ÖIJ¤(Àîágiâô”×ø„6#‰$Å:ŠSRvIR.·IRIŠ]­ß…>µß•îs`x>ŽÅ|…?ÄrÀ,H¡€Ž3ó(vTZòG‚Ìý™¨®'Ü»NeGägI’±'`FÅXÓHQî=ð™àƒ•cJCâ)Ÿ€•Ã‘SÏÎÊ?++÷ðíÿ+·ÃrD÷j|:#G¯ÿÁÈýÁÈÙ ‰¡'†c~<#‡#¡ÂÀÈ=Á¤Ž‘ëMú#·‡°™âMF²Ø³‹/w¨¼~<¨óÆ—âIâÉa~ä÷rs!$kšýŸ‘sÏ~ÖÇ1pÍ@cìþY y.C»{ÝÁs¡Î8:Wú¯¿"”aï pzÿsô I endstream endobj 2011 0 obj << /Type /ObjStm /N 100 /First 1006 /Length 2727 /Filter /FlateDecode >> stream xÚÅ[Ûn·}×Wð1yá!÷Þ¼F_à&­/‚ä¢M?(òAkÄ•IÒ~}×âG²+ät4 Î…›kÈ}]¤b+Í[ÅZ؈NŠ±!Τ?R—rfÃ\‰ÂFrÕúìØ t±¿]] {h5Šä½†ÿR`φ—³*[¸,¹²ÅËÐÐQ´ä$–Þ#;ÑÐØ*NL{ê$Å­mÀeÁI5a _@ôh‰Ó! šJÂ+%£A-§ÚCÕÚQà© db:ÔJÚ«©9M) ï§ ÷JTÞSg1'¶ ³E¬!$g&½•¥Dp˜G˘´¢³ÚŸ æ·eÙC ú·‹¹$Jè’\R „VvÉvO Bú½êR)ý^s©ÞÓàrPŽ¦ÑåØ‘BTÖÀ10çٔ㪹œ2Ñkr9·þ^vy‡ ‚[ü^ˆ*1ô§ÍQŽaÁ-¼gÑ•‰s^²ŒaêJ)D`Д&à*!õÙÕØ(ÙŠ«*œ «P¤Ôï5WS%¬R-}Æñ ÖÔÐŒ‘Ôµ¨|š£k]S1‹®iLl%´ðšàšuðXþfè%PÌfÔ—€%iɨaP–;¦A!–À! ³ÙWJŽáDã"zö‘¡—¡D~(æ1†j|7SB+„  5ðûi8q·¤™6¢¹wƒÃ"8Z†jÃ$øm6ÁnXk_uZA×41šÄD}㇋ô +‰‰£GI© Ãh’k—@“¬1í=x°·yõnóðääôbosøáÇ‹~ýìÝÉO{›G§go·g¯<ü#ʯíF@‡ïþ³=<þ燳WJ£Ïˆ……èmówç¿- ÂbÚ X3ƒãÅþÁË¿.@±¸v @V¬wœGðøå³dhص…hÍk›ðüѳ—ÿ¼‚hÙG¸rÿHLK*¬1Spnž„¥1Tï*‰°[Øë†ÃÇßþå`Aäç‰í NK·@ 9<z¼¤àì× † ÂK-·Ãx±( µèK¾ZmÁ3!¼Ƴ÷oT‹lIòuñ=«AÐgRDu‰IÖò–&‚86¡°†_äss(îÉ_B9˜á%hjž|/¯9­a$Ó‚ó…‰êX¢ýjF‚°.íŒbpz;ŒeD—ÚƒF“Ú`,j$š`ªuapÛ,ˆOò›%±4_”µ4éVd|ç)Ô¤¬e¯ÃL¨^ðà !‰'$\ÔúEÆú¢jôàÜæoßÿÝÑàY$ž|xÿþÍg_Œ!ô7sK½8¸åíR±‚¬±Õ³´½ÛÛÖ¸îñ®o#ϨP“»áVØ9ŠÚÛÞ†ã‘^áŠÏ½ýôôä¢ÏôS¸N‹¶ëö…¼áw(í¡®—(3jÉË‹àR™žDgeêÃ'CZÆEÝ=Á°›ý³ÓãÃ-4ÀmöŸÃ IHbàKæ0ÜOª-…)‹^!AU\ã<’K* `ÄÚ1¼jb5;ü}ðDðV–®`˜dä3«Ã˜TSÌÀMòJîDÀsÕø{ðŠ"¡'Ù)ß÷­ ÐÁUª³p[ÔdkÂ|D—BÆÀÀ¯Ìˆ)¢J_#–ˆ4¹z‚ddÀ¢á4Zñæ¬6ß"÷¹±WÆ-ëz Ñk îÄ!®Å!ùïa ×iµº£˜‰Iƒ¾#¢¥Š_äþŠëïÛgiÁZp’» ¬þ4zf„Ö•d=²E ÷g˜JÀ6áÄ=ËC}ËÍû3zùhY"‘Õ'k(­ Ρ ¦*=Ç1µ;y«e·K,ä ‰›ÎºC3&¢œ÷©¹"µ+i•ƒ†Yk½ÂPRO8æ0ÜO‚a’Hi·’XÈøçNWÀ}®æ3‘Œç.aôíL[¹T˾4ü澠܇gOqnórA$WŸB?žáÉx£zôóÑñOhåxøÔîÈÃ_ñŠý6ßNîø6T(ê­o®´I¹£l2)Ô;ÊŽpºUìsÌúGüùGÌú5büfý#6þóÌú5þ·2ëqÇ„Ĭ³8úÍÌzìrìrìrìrÌqœt½òè•G¯<õœtœtœtœt’Ë\†ä2$—!¹ ÉeH.Cr’ë\‡ä:$×!¹ÉuH®Cr’ë܆ä6$·!¹ ÉmHnCr’ÛÜꢤ»2Ÿºâ›¥Ö^¬Ïq½÷Öä”p¿¢ˆ›ÂÀÛ@}$uE¶`dš)”ð”e!ëYqÝ>»‘?@Ÿå sºÐ­ D¸‡ ³ÌŠÒ”)Nn=†e«(ÓÚýíÈ ÉÓÀ<èÀ“¸©"ˆ~¦F^4¿dZs([]qxL<½)Lòø»"Lźãp`'7gSß?_@ËЀi|3nŠÄÙñïGcìy½!YµGšÙKLX ®³;&™%Ö5 È%¹C5‡aéÝ1¤¨k¢CJÝp¤€yQÌlZ]…ÛUõ­ðdµxHh3òIDs2{šË:{¥ðC•ÒO\ÏX¶èdmƒä Ù¡(uH^¥¸Þñ·ÝÕ Äe¡5‡bñ3ªÜ‹”Ò÷FS/yÉN5þÍŒOŸÙ«]Z/¾í}Åé蛢Ê)AW«¾áxÊ‚úSHîÎÀXÜ?%D%þÉÑÀP3bVÅ°ôjTò„Ú¬ÿYY½cy…Òá6Óü/}Ù2Ò endstream endobj 2159 0 obj << /Length 4445 /Filter /FlateDecode >> stream xڵɒã¶õ>_¡KªÔ‹ÆNÒ©>ØãÄg¶Ì´ãJìØ»›±$*¤”ñøëó€[«%QjŸ‚ €‡·/“û‰˜|÷Bøç77/¾ü‹“$J3“›»‰ÔI =q‰¤–“›Åä§é»õÕLY1Í×Ûê37·¥>äܸËæÛ²*~˶Eé‡o²:¿ú÷Í÷/þ|óâ¿/$,)&²³„Œ’ÄNæ«?ý[Lðñû‰ˆtšL>ÑÐÕD*©8†öròñÅßy¿:íìW9Å.îï÷ga­ ³D°ld'^>|Ó˜.Ø*Ja'‚ÿþÝ7þo>¥Á’2ŽR‡Á×W3™¦SkÊ/néÏ;wu^q«~(wË|bz_\);ýß•´S? ŸÅz³Ûò fŽ»r¹,ñ‡OÅúž»æåjS®5ns2“NFF9hˆ(µ)﫼 ¨ÞV»ùvWå_õ€ ω#8Y”ê˜çXíV›zmÉ8™8x}*réìI›F‰ã™ÌD«n²ê¸( HuÇBS¦áØ?¾üëo Žh+>ok½å”Ô0<îoíõëoyg}Ô‘&ì ‰¯XosÄï}^!]\ͬV `û6ǧžÖù–;Ÿèùsc™g Â8¾,ŠU¾®‰±ð/Ämp9Ï–Üü8ØULI gЧ $e“Á²FÉé*ÛVůÑÕ,QzúŠ:E³Q€Åç2«®d‚ñ{éŸùw¸26z>„xWØ\ïV·Í¯wü¬˜¬k^4ôn²ÞÞ¾ÇÈÂÛ$›È  ;m#+ã‘dÒ“—1GÊ3iéW}óúÝËC¤š®K0ž‚6Ó*]çxø€çÛÏžº+:ÏÉðó›Þ¼ÿ¸‡&5ðA+Ñppz"Ê_‹-OW•+îg”A#[gËÏõ•œ~C,éɓèvð¦*çy]—UfÔ±D2p*qÚ§=àëm1/6ÙÖK¤b=QH»mGƒ<bDÝÈR@²DíøÕ:„£LdΗPÚHVV0“ `j~®Ë-7Vå¢øY…Ä÷½L@Īô•‹’´íÚ3Äy”sšÜiä¤y¹ 3y–Ü~tΑMã.Kì™ µtÃ6$r0'ƒ³ˆãfà—{g2©X(þºoW6©l¹(Ÿ5’%ÄtS¢°¯ð%™fU•}f‰ß‚ ÅO(H±/[¢XÜæ ~¡ÏDáØA63‘’@¼&"ÎH™cÇY8`¥Í™¼}ÿáÝe{”FVÛB[èCèvµ—ï^ˆV«ê-Z/³+PÁ\®®ÜÁw¤–ðòP†? ÿ™…Þ|¹[Wâ—;~¾¿JÕôëׂ_³õ¢=ÜáJ„’ÔD 0ò©Ø> êD«#qÚÊé›÷¯øK•­©¹…ž" ;€úV»u4QVü VÅ-ÿ¯X0•j},F”Ñ”œ „iHx•}æ5HbáÔL—‚¤3÷ Ðííð¾*ÜŸèHÅDÉ|oË h•Z°) ðXü†‡*lǶ´:~ͶüVOí›Þ²À¯ þéÄ'Ãc¦"ê "ÏÆ.Šõ%6€6*R ÏduÒ3Ÿâ/t"b3ä¯î@‰µLtžSãŽB º yŽS0BE:œÂÛc–Ù¶9†c^²EÌÿq$ÄÔ~|dÆŸ„ƒya†$v} Õ[}ø3°Y¤”H–‡¼+å4s ç2NÝ¢ï'€àyžÉÆéÙp:€&2‰9æZ%ɳÀ“ð½ ‚¨[ÆÉ0àËXã^0•PÏ©V ˜›ªécÖ7³’H'jyèëi4~óÜÛñ‹%Ü:XÅÙ-+8±àëE¡€÷؆F¸A ×!'†âNÕ•±Std. GYXHÃQ)ЇÃQq„ÒÔ$‘ß»¡€àc)Õ±•l1Ž£ ÀÚ'ן"GhÚ¸µu×Û¬X×¼ú<=Ú–ö®7Û(í]Ok8Ë|áu¿F¡×—TlÅ:øq¹[­køK'Ú›:.nzWV«Œ¬Œ†VU^oÊ5G9h\9¯¾õÓ"¡|ž/‹9ÿ ç ’1òÛ“Í`´žRu¾ ‡¤:Ùî/×Tþ@ÉÔd}!-øì<‹_|°¬­z¤d“N7tòær;¸WðØš­ŽoàŽ$|{|5E…ÇB•>ÒDÍ7#¹¼µ‘g!Á´ñ1=£Ð„UèЛK¤o*<œ)Vö4éë@Õ÷ÂÀ› ~b9ˆ¿-1àbö±5l#ùÌ“6¾Æ«—oo^£=*S2Õì¡‘Íך—'ÄñŽüÖ>ÎQ¡¢íÕü¬?¯Vù¶B¾Ç×ñ&°Ô°q×"òŸoN>ÒkÉ‹–~O!Âï …8×= Öz[hÝT bòɸŒß<žXaÁàwÅeÐòÁ™à)â~\fÄ©õB6#EÁµ„í‡U¯d]ò °¢(W6y^Xßžkcô4¾,@üP.ž1>–¦v‘†·ÿߢ´k À”ÊP‡Y—^¤ÃR™CÖYîšá” ø§b¹äÖs‰Ù’‚&äÌðƒ7C°¯—¬€O„À0k™Ày7ž2Z+W:žR]¤> JTœtf˜!“e_äDGÒÚ~Z§Þ‚zeì,‡IàI¶3töfþI6ïÉQÇ7B(8„å:çŽÆ%á×3Î;½oÓ“•x܉¹LyIyºòÂålGw!Ò Mpê§7xèw,9áÓ'ÿ„¾Ü ;¯Ô—-B* >óÀ¤ÃÁÝ$_©2¤(w5j(?ßÑ©CoÆÛ„*B¼žWÅ& w¬ŸzÓgUÖt^ùÉý|È®ì‚ÓàÂe}`›ØØýnnõ>v®rÌhäëE®HtYÞÆÆòÓ\¤ƒTŸPA5íδÀF˜‚‰ õ&Dyö†SøS³ø-"ì½õ?zA«v3’­ŠX?oC¼Æ'º k].|ßX·Né42¦1%ßýá˜{Ô‚×Ò¶Ø Wéã-ú!£P’ û0'æ¤4zà« 8%Π{„tðÖæ¡ãÓ•D5úKãë…œHciå vü IpãTKF'œPë@Š@(NE©Hú•)¯±òe+ñ:<ëÝj•Udãkæ{ ¤n³¢ÔÚ§èèßü ÎÌym€ÌðüµâV†cݹû¦AÄzšB7ñk¤úÈØgÎSŒ:ÕA<¢Ï–I¯Ã«XL1¤µw$Æ0¹ºÁ†LÔ˜Ãk\Á¯þõç'r-Z3¡@¹Ks-ŠgR2>5ú‹INsI˜ãØþ÷ׯ>Þüãë}—D¡uÏ%ÆÔŒ»JV…·¬å4Ϫeœ`Æ µÔA%J2Tå´â—¦ZÛÄ¡{úu˜Ì èÝ Cá]-K–þ°È‰hô± ›€·ËnÁÖ±Š[®Õ %HOd70‘b”™h™€¡f70‰Q‡Š¡€”ä(I¡ÚêþrÒ“)l&°µêW0b¨)×)ÂEÕ1‰SœÒ[ „‰™’òs ×°¹Æ%Ã&! ž!éÅo™ïìz4lì;_9G- ÈÚÏH69·üë_ÛºÇu/~O`ÃïV •P³jà„J½q‚ ­„i(  þÓ…dæÖy÷¨ä¤ÈdËTã©$‰G»KÍT,§R,TŒ5Ø…%y¹Ðé«„v+ªà¦®ÕŽôVÌå8*Vƒ úm½è‘XÐ]Ì·D$ðžx±íU–ÓX&4~Z)*?Ù|»ãÒ¹É c•!Ææçrç%7R»…Žó‡l}Ÿ$Òâ¦\Ôzî[£~w¥íôÇkâ¼k]*@¸b½G—ùñÝÍÞô4˜ÍÝí¬øûÜ‘Àd+–_xGB†S²ö­3½Z³76 _˜v‡ ¨³ƒƒíXØBLQ<Ì¢cñ¨Žáé-9ÈXć³Îð'n0PúKö‹Ž”Â*¥¢DÅÏP ‹39•<߆³¶¶÷ Cokû¯0ÀÎŒ¶g JŒèćÍ`°€UÜ™@õ D'#§]¨ãb¯˜ú+ æhŠÞX黂Ô7ö²#…ýœÛƒ®à„Ñ`rÂè÷02dM{kÃWÁËHó «OW¸÷«ËC%dG¤Û`^’Ýaí“âû¤ã¦éùì½L35ùìËêÃá(ÕÍÿcÁî¾éddÛ¢ÉCEâ ß娊óuâ&²²aŸbÝ+#¶þG*Cæ/¬¢«ÚgdxÔ£òrª@nŠ…Rë‹…¨¿ô%ÌTV;Š[g(Qãõ“2û½W¶/0Ú詳Ý“‘€fž)vîi¶Fe[¼|NºéÉŽ¦½D¥AK{Ä¡wÑÑ;-|<¾öî@76Ù×áA m´œÕý~¿sMÄjÂD?KMt ¨Ž´Vøć±6Á—3jêbÅ69¹¦Nã¬føžˆ-nƒîKYÓn’£S†’j¡ / ði‚8ÒV®°ù„xl;A9ð*ÒÄL_Ýñ^!´lbÎÑaßnÝ)£ÁŽ3²6i ‚ð¼2ásVV‡º™ÎŽM¨€Y •¸H´×…ÎÏ (ÞÍè¸ØLc…§Ñ‹ê¢àuÅÅž ÏK¦>0~%§|¥Rb¾À.J.˜HØEÄŸ.4ú¸‡Ž¦¼"é—WÀ;Ñ‹L»w¡7Oø ï­˜i©¸@"Ê#Œ±)Œ`7™­²ÿPº z¸ Ô'ÕLꈊ۰ŒhòÐÐ.üô8Âjc/@‰È(=‚†»! ^5€ ü/hŽ&$¥žtÃÕðîœxà¡Òk—4a$OØðqLŽWAU€/OÙyzç›@ôïÊ„¡ÝÁ¾sÕ1ýà3ÐiqS;ŒÎk,—tŠ pG6º;Üm6ùÞZî^µtáÖ´šè-ð_n‚NºÜÏlŽq³|Y\‘øJ,Éú‡ø̧tÓð³ÛÇS(©éË”qEºK5˜Ä/Èpß¾-wÑÜלÔ#8JR€9røf²ŒE$èšc_sv> stream xÚ½[ÝsÛ6Ï_¡—›‘g"†~´Ó‡~¤­;¹\.voæšvæh‰²y•H—¤â¸ýíb$@Ѷ$§÷à¾`‹ÝßîÂáìzÎ~xòï7—/^}¯²YdqÍ.×3!u µšÅ©„³ËÕìülÏ2‹çMÑ횪XQíêõ¼©Ï¤žßñ˜¼âî†ú‹†Û›2¯®w›31Ϲé6o:*Ù•ªšòå²hÛbœ-¢(™Ÿ¯G“os˜ïmÄ~ÜÞo·4/©úk¨Ã³ß.ªÃ@ÀŸž5H¾­¼ÿ˜…”Ê*cÈ¿ø÷ßù{âÚ˜e1p*³ƒ¿´jÝà7³…Ò:H¤œ-Dd:£AödÆe†_Gm(I…]îüÛ·—oB‘™9Ùg”‘ö©^ž-”ÈÊ Ja8¿ª»Ú³7óÏ.³‡›Íw··¶ÍžgÎu<Ì–&„&1/¨leR'óoŠe¾k‹ÑrË›ó-‰‚Ó–õövSl‹ EC‡tÜðÛ÷Kªw7¶g™WT¸*xhQØ¢J9Î釥y±Íÿ[7Üc¨Þº¬7»måŽl»ºÉ¯‹I€c“³ ¸/cä~8[H¤‰"bàvEAto~nËêšf@î•ù†*ë| –æ]Yó¾W»¦ÛÂúCÏíMÞ2™VâÇ’%ìi,92¶’c¶<˜´š;d. ú±”ËaOèðb©Já(“ ¬P¾FF&!ȆÐóO·›¼$­MeõÄu˜}0ã.vWm±dò¡®{ÒËàV8L#á8(§3Sô„ ê7æŒ"c?Â!»Îî¯?€$d¹…ÂúLÀäîa¡ ‡¾üš‚-i¥çE ߢ$¡Y¢$uÎk|ž8‚wÐRG¾?:™Û¯úÉʪ+š % »o›ú Ȥ®b(ƒ8MG•Î C!)>ÜÅ  E BíóÊ¡EÆçÓq­'ÃtáíÆÂ÷‚>YQ©«é÷×0”MÛÙ©ªUQ cìMy}Ó-nÌ-×®(­rUP¥®F£Yv°ø5EêöÔNøñŒ–A–ÆÏg³Àñ¨iS5¿dý΂¦ÂÔ嶻 ÀîÖP=eK-ÛܶägÀ"¼Ü á4n~oxœECM뺡&’bsyìP#°Ó(Œ˜s)Q°©—(º wŽœ«PÁ¼<´kI{$ØMp) œö/žnY7MÑÞ?†ië½Yýƒ6½Føx<×U1%¬â€¹[\€Ì‡¹ÕžI¹ÞÔWVûûêýxYØ!ž/M’¤iß@,D&)3(ÄA,ÓG Ëx~=¢US"?"£ á¬fÍ„Ë„l°qÐQ®©)§ê\ZÖêPó´: P¢` Ÿ…VÃÓpøÜ*yh8áâ&À3©ƒeÚc¢’1TF 0&¶iwp0Åû<ÍàõàÎiÀ;XS=²¦zÒš"±ö~Ut Ú=â"cOe C’“(Šh“ïÌaîS"E‰ž“_àåÊz?V2r=" ¡pS£–ÇRoŸÝnGŠ f¤( yÏù³»r³á¹ùÅ|ÓÖãÒìþ‚)ðÔÈ«¶’M¬¼3Ÿ7¬ŠM¹-+ëY Po­þp!àþNTR€üêhO~•<Åô" Ç€‡äÖŒ ߥ`tÛ¶4¦iùh﫼iPGä÷Ì€Šô×›ÅjBŽàmå ÒQ 78éUÔû×ß½ÿñâ1.(P„Iÿ^·Ð?x›o&{Š•"ÖŠ’§Y¹ÙRí^6ŘS|ó±òçiÂ/Æ:Bkp¿;0vFª“(v®ÖX'!Vl2ÄjFÔûòl‘exë¢!±Ç¡hB½o«º3âßRûºþ„ârD–ù—ÔUƒJG9 [mîiá(´÷mWlYqGã Šåî×4¬¥²$1Îa„a<[ÀN²˜FY³:£Të^L¾œ˜d0îeg€sMhä@¿Ì§‰Y`¯`È&6ã#¸õè ƒ¾šXOPû½R¹šXLY”MRîÊg€‘t3ÀY—ßà†Õ ú‡ ) ^¯G½ô5š[$YÄ©/„‡ ²ypÑEs½^·Î%‚º†Û¬Ÿ[.ËņlsçÏÀwÊêðz×" Fw±—Z$à41ǾŒê¿jŠÕnYP ŒÑ•ö?Ö™R _U£¡D–Ös‰‹çÿ0ò=9ýøö ¦ðíYŸÓƒ=3Äù‘1ä¥9 éÁu¨áºd¸.­7…ÿX=ò«”5¡!«êjah ›Ç°šJþ"´ÆuAþ:ÖîÊ3ŒšM}âV¬æÄíÕ+ÇÓ2Í=¿ÈjÄ pp—£¯Æc©Îg%ÃÇX±W†¥ ¯ › ãá׺Z£ÝhR¡FKj~Ù¥‚#ª ©v7¿?΢ea ’øtóÉ»ÉyÛÝéo0ß Oב « Ta<`üO–ÖDÌk©}SäÖÕÓóU .BË°ípâàòEÔ#Äþæ*³ §‘Hrƒ“`ñPM|„s¶‘̺ßáøþËGîÿà~ÉJ0ƒÔàÞªÁ;V®»…ö—?N4›ýÁÞm ŽDŸ€_œÀÇœÄ,EoRÍ­U¨*¼%MÁÚ\¦€kÔÈÆ“ÂHI’¤ŠÈÔS5ɾªá ‡û…å!GÔÃ9Iã[`K¯³¦+½Ø|?š˜£'8r2°tWo žÁ º–zÇÊ UÕI2.Â8ÐâQP:!ÜJÅ;bñV®xc@IÁŠÇäËß]g´ ±®ìúHÄÞPD2Öz“ñ(Ê:8K"Ceq~‘‘4M×N¸¡¢&W×bt­ùª¦–>Xƒ•~ªAdplÞ¶õ²¤cu×î?Ps´I¨YáXz5q¾ciŠ@šÞÖ&V”E¬ëya’h¦à7µý–¿°0Š#;ˆM%ÿ²Û %66ÆÞ;Ƴxho&ˆ(«2Úæ¶ÉmÑQ ûÊÆïè|Ó=¿ã_gBÀŠÆ!güjØ x}^È€7GÑçoä–uMA§å&wÂàï5ô÷õ]±Îw›Îq³{¹^ÖB‰õDi¶ÓÁ?ã6ìXó:ÞÏ+”`cWå¦ìî§|À(H27ì’‚"¨F9Ç1=h˜Â>A?æ•siòŠºŒÊ9xn¶3¡¿omX–#λkÀÞ†{IÍMüŠy¸¤9:ìZ•-Ê+zÞû_|⩈ƒ¸ÿîè|®ÐH³ýeÃã/K‡‰Éð{âñ¾Ø 7á6§8˶@(0#2á’…0‹øÁ•cSØé爲<àz’ƒc½Ñ˜ƒÛ¼ù}ŠSJv/fºÍC¸`“Ár/>¬Á'½}B\XŠÈ‹ +Åw×'åÜC,µ7õnƒ¢ 3×hS§±Ò5z›/¹©ô§Êç[Op¤A’FÏ ¾Q^QÊQ^É(y[¥’¾%§Ÿ>A߉þ€S‡’ĽÊáa‘{Ø°¹‡=ãÂqÈŠ³èò0ŠP±Eð‰ M+|tCu Tì&RÈ$£®£‡„ÜZ/«µbfÏp`ãWÓOøFÑ‚%B¼lÂ9bL‰ñëÌ~à"šh“VÀ›¥¤õe¡à8-Pã •YÒ±|eû݈’Ô}ÂѱÇý±MÙd6!†Áò'ª|šff7 õéä‘Þª-åŸØ32Ëx’ÏLѳ—Tf¥¢¥E|r¾®7ü‚ˆ]…Æ… KKC¬£ {GaÅVÅKUýôÔÀ¹§ c|÷¼tímA @ÊÈ Sã‡÷ºâö‹I&#K‹—r#SÂ÷°ÎYs(q¶q_Q‹0 Ôøü01•Ýlÿ7ñÒJÓÁÙGã¼MySɉ=ïMõÛDdÚìZiÈ,½œ0Dæa9gÔá7˜ú}y½k˜ÁjJÁ1ïÉ×$NøëˆVÍÍ‚ß²5ÅMkúíìÑö:€ª6_e±9~Ò„3®#Qb#Ú?=‹2»ŽçYÑ-a]“!ÆÜçª1ëè?83¡DêéG˜í‹‚©ç<á!PwP÷Iì ŒÜ‘ºI¥ ÷›'¬$À‚!æsø³Ÿ¾=`ñ8œ°ªã éYi¥4ZiP툱ŠÉ™BTÒÒøœª€ºš¶ ²•ì>áqHL9§D@øÍÀ͈#|lp6ßþb¾~}ùâÂÀYHi–ÌD§2²Ü¾øð[8[AçO0©ÊÒÙºíc²^›ÙÅ‹Ò“f_È2ð‡SšI1|Bü'½/vn1=AÖN\É.äq1ŠÁøËø3p1Š'"ö¸xñîë÷¯ÿ²´øô;Ÿ$TÄàè€y 4”|"ÁÇ4Q$Åÿ…Pß3¤OÂv•<Ÿ>pÿ€®Ä§ïÝåû§®Cä$gžõ´È¨>9í¢L‚0cj•E,¶»ím;!:“LJ{ŽxŸhiŒ3!ÎáàrÞüm✀¢È&ü½1–öâ&ÆŠq–Š~ë[d’ =§(±ž_D…8S•a ájaÿ#B8.3ª÷`i‰5ýöƒmÆ‘žÜÇAšŽŸ…$œò’²ŠD¦©ëMÂô1'¶ 2ÝØpoÔÀx JwÕ?&J€ÛLV´<µöx{9·í­§”†ˆùµ ó6LûÆ+5ö„Í›Û8›Ÿó“Ðî ßvüÖ”ž+8¬’›l^Sq^SÍñß(DJ§Žõš‹?vô‚Õ¤$Ž4õ ›²ÞÔ_œÿòzÂÜ*WÑ,‹ŒMy†µU‘‰8ÁD!LDK~ûãÏ* ’—ùé_es¹˜ùþ“KõÚ{ú«ÜGºC¨ÂÂúHs#¾Fér• A}ûdþIï £uò°ÃùtÝ× ‚<ë#O™ÉK‡'e¤«¢X·?‘›^ûÿæ²à âó!™eBÿìzŸ€àý> stream xÚ½[Ûn¹}×Wðq÷…CVo€±€-Çñ&²-H’×^[IŒš@’ƒM¾>ç°‡ãu¢i ›V‚Dΰ‹§«Šu¥$”æ‚“Pƒ‹ÚÑIªˆÓÚê’DÌå”9H®L_eפ?U\ ©/ª.Æ0j Ÿ57+ESé#q±iêbµ¾Î\l%q„_1p¯†_¢ý3<¦¹ð˜5=Âs’…ÏFÁ(G˜–HTÓÒGk)aàKd+F™ÜîO—”\?]²ÒŸm.åHÊ`{*Æ'°Qª•ô@4‡é[u9Zÿ B“B^IrÙÈ°(‚Ôþlq9—¾®º\Éœ(Íå–È(D!#0Š®ˆô‘¸¢©Ô£x¢š+Yø ZJâš©#Jqµ3;ju5vn€Ùuâ•W­¿¯EWS#¯¹ôÏÔÕJ-þ¸ÚŒ{”.ô÷sÚÄ+´)õ/ZsÍ:'Sp-÷oñE›xAµ‰WxAH6v¡CíBìœÆ¢¤’]JŒÜä* )djm0ê_Ì‘*o|×ÔµZ.8ÌTÕ˜@ Bì2†ÚyŸ±/^†P¡­<ÏJÌ\[:“2×ÖD´Äbk„›q¬ºh0‘‚Ýp€04ž<ŒaRn yBÄÓì&µ«DÁnÒL=:Ú¼þ×?.Üæñååöæhsþù§›>?ùxù÷£Í“íÕ‡‹«7v!¼Ý<ß|¿9~ûähsvñþƽÑ}&X3_¡jÁ“ùÉ| Ë»GÜæÜm~»}½u›§î›—§Ç¯N¾uß}w„ŸÿA¬Í$ }¢þû¢#Y†Xñ­{ŸŒ*^èf`¼xròêø÷ bhêc÷l•âÍÚªTyõ †„SÒ,†—§g¯þ¸ „¼æ/ZóÒíòj,D_èúvL³ï1ÁŠ‚°Ð|€C‰ dñÞŽV 6x­ca9a»=ˆBÍ€x¹0‚çxñ\½tWÚ|òÆ«É*ž"Ã$á ÀáûÚ#“Šs _‹-’W3Q|Cœ´‡‘’—ga,- IÅgl{ 5ÃyÕy ã·.yí‘ùä·yÏk8îà qè@©óû? šL¶yp `^ò ` €\e·?R(bœÝÿ8ðÊ„@÷Ìmþôßm âò‚\äòó§Oo.äÉ/ˆ²˜g1¿g}¿ÕH¼´û®† |)÷E2p+Î ÚýÃÄùVþkõ³íåMçð3$AÌ/úcÏYÜÑx†ÜƒQåîwȧ ’Œ,m7a8ñÍéÕöýùDì6§OŸ¹Íë‹ŸoÜÛ¯µæôÝ_/Ž6ÇÀpqysM§ÈüÿŒÊq½ý|õþâzÊgúg/.>||÷dû³ëú”¯t£}úî O3‘ia×ÅklÜófâéiónÇ ŒAƒ±8ŽÅ;~ô|y7Ð1°1Hc0(ÇA9ÊqP–AYe”eP–AYe”eP–AYe”uPÖAYe”uPÖAYe”uP¶AÙe”mP¶AÙAm´A0 ‚iLƒ`ÓžàõíBN'ÏL®‡!@MHªË8’oO•~÷êÉ‚öÖhC’Ë*ž†¦ªB§225“™DéŧíûQ”ˆôÌ¥–¡3a72Ë5˜ç²F\ŒÓæ Ü‚6Ÿaøç!,›³ÆèYêHEûÖ=?ÁáKs[+iE–ŒœÄö(€À³x'Š—‹j„YÂÁÐ/0vñù0–VL$l,!"T–ÃD=|h*HYVèÓÃìì1ÀV°||ˆe" –*·= Jfÿ.Ë*'¬ ¿†=°®„ ÁbBºPDgçÇÏÿ°d|˜aàÉ’òhDÈ­úW™ ó–VIá#åŸ÷°#Ž*w@X8m„ðipÊÑ`³ù‚ѼNI II ¿ÀÀ–b³–Îi¢Y¾ éŠÅy><@9“¼y_e终B0/·û®ï_¾>ùñ›Ø~üvÙÃÁf×¢µxaSfÈù/–4×؈^–òêW¶ƒ¹È¢Y)K¨VÊ F/òÏxÐL$„Aà ™wçlÕ”H¹1öUõ¡GvÐIÞÅ®p ²[V"xËa·¿ÁPЀÍíÿ |=âj×´‡Ø½ÆÊÃjß+ÂíÝÕTïÙkþåÂ}¯9Ï+Äw¬f…ÅF<&öŽÕHËroÛÓ-Ê¡ïWÜÃýÞC-Þ_ÛÕ•©ÃúUWW¦>ì¯êêò.ë®K8ºyô óèæ±&ï׌ŽdÉ<:’et$ËèH–Ñ‘,ƒr”Ë \å2(—A¹ ÊuP®ƒr”ë \å:(×A°‚ulƒ`Û ØÁ6¶A° ¨mPnƒòh‘Ëh‘óþÅn Kö^ .‰—öá ÕpØÜ[¯¶‚[ˆ,X#~Ë츩õ":ïDf‘ºfŠ 5d ÖHú5Ýl¼O+y° ³«Á0_ÒWf߸w@ìØ}eñšˆ óy_)yY_ ³hì{"熈,š±!Ù0Ÿ÷Ë‘\ᔊæ>ḰŽi…7ØØÑõƒ1^ á?[ t›Šì"Jp ¡Æõ5e¤ýìô@Dýß’Ïa‹¹®Â*Ä‚ƒnðÂ@ÿwß{1Wà瘢²¨š@X'd‘Œ}IÞ±U¶!0?P"9ûÍÓ³ççË^`H½è¿Ã…¡¿šÃp²4ˆq£ÕäÐKVø‹ØŠ×}í€@L9x•ž–qá?­ðv#"ƒu«ʹÅ6ãJ›.Ÿ«™6«¥ûHå?]€=Ô endstream endobj 2241 0 obj << /Length 3769 /Filter /FlateDecode >> stream xÚÅZYsÛ8~ϯÐËVÑ;B¼¦jrN-i‰èüÕËó7L6`©£ç7di‚ B'žbh`ÏZ†å‘ $Î&XÊ@¨ ¡ûë¹Ì”ˆÂvTÞ–oS³3Bûí˜iγ㭅w<’žó¾b9)«´Èa`ÉEžÌ—)ì:6ÃŒ¡1r6Ez$¼NJ®Çeß5ìãçÚl$ì®WD^ij¨VÅ6[©ï;W8?pâ,+q4ÍwÜÌ…†mEã@ÓUr]”¶5ÁáYa¡f‰§*²m SåæÍ*®q4×¾ëœÔ7Véß 1ÎV²lØ3A\s=K⪶£}Ùòv8 ª k Tðß›•¨òMåu߸½M‰„’íþžvšÕ³O U,re§®šØi0Giî?§>½ÝÐ`,%…×™Æ\¢ªüò°ñ@Ç@7Ëââä߯víä/‚@Í<‚‘›‡Ùýpu+ŒÏœdäÙA_¼ùpþÝeú"ŒÚe «Ò, pK‚Ä`—èÓÉ5hH¨¬†Ú)“åv*ø4kQäK°Øª$|&•ä.­1@ùÊöÞ$%èø:±Í?°™R cZéž¼x{yŠ\”OFý%›P˜ng£=†iDtØéó2”ÃÀ‘Ö\».‹u'’•"¸U#óo­SK‴v-ÆâDÓ_ðïgÖ¬>P³”'|sÀ¾† ß‹z¶ƒKÆÉ¥¿A‰LÍ“}ñz€ÏaC'­ $ÿ(ø™Àst]5ôÇ[ŒÕÙþ´è@‹À÷gœ0&|ŒèÀÆcN*4?d'VvŸ÷ÈëÊN>BvêÞ G¥n!ð6Í2^Ȫû$uÖ 'Óœf¡ÿÆM"›'›ÅJz³ªç«8·õ*]Z2Tlk #ÑHé“Ðí î˜D·"¢ ¿Ï@°Ù†¬Ó7uø°å ⎈OõE]X7®¸> ÇÙG¢{'žE-;s©wÄšL œéMà#ˆ’e…s!äØÄäQð·¡Øb"]Ù¶>&Bõᘈ®_ åã1Q5˜¨dƒ‰0ÏŸ„]®nߺÂ!t±®Â¬êJz÷àè§ÌÿÈ&¢"uàÜwQw½™ "áËGû®†`Œ9éý(ž)OîÅ3-\×ûÈî žá¡Ðƒë-¹±°«&ìKlª+Û¸Dº¼ã"xµý8PöÝj¨‘½Úá»Ô6ð„Q#ulLß‚i#M(~=RÄi|•%UgóÓÈ¡·Vðm8á$PšÓÿpºœõˆÀ S¸p]8íÄ¥Ùœà^…Ή’<Æ…‘PY´˜HÈ"qüPÔÃöŸƒy”Õø»áóþ„D2 FˆU±Zå…Í8Ä„|Í){eÏÈá¡8ß…¼gÎÞO…퓾}ä ©ñ|÷E¤­ ¼-(Oâk©Ä¡¥iàãA´j¨é%I@m"Ò^/Ðÿ8….¢K-ükB­ý¥¨µœàb„ôj}?VjbÊ;¬>YÙº=V4k-B×nâå„üátr lzG•æ÷°-g›æ‚²5’Îà.€ÙrBÁpæÃ7Ý¡6Ra—ñ:Á4†q»‘¼¯‹dS·½ÅBOx# eÕR#8Ðï2­`ël)£¡¥D=Ú¹]%¥í…á5Y‡“Ã@liæOTù­ QÉO.ÞNÄ Fnaˆ ‡œ|×z}Y±øžÁc~Í´^zÊD¶~P5½¾(˜_Ÿ"ÛG¬a·J’'I:¿¬Coy½áPÁãîÞ¢;ôÑñ%ê.¶WU²èDǽ®?å'¥„Þèõ_cŽ B×—Ì úz๮ë<Á}fŽ§Å‘t[®œÇùç.Òx~zÞx®sãœþ=ŠF&Ð_Á¹RíM{Ì͇ PT†…æcÐt¼‰QLà÷ýë ,gº„èÝÀŠ¥]ñ%B"g±-Kʘëa‚•¿²K1ZEè ßx‡Î0 JÙùƒi“š¯˜qÍ㇠§èKÝÎK’/~ºF©EŠ„[qMØwsDŽ˳9¡¤vέ ¡‘.aÚ1ÁXCŽ÷ÏúÄcô äJ'òyã¬*2ŠŠŒu-d0¥È¿bþÊ뉇Éé_ Šµ‘ e²)“ sÐKnH-{«àX}µ@¤š 0 å[q%ùÌæUÁ÷M¼øßä+¾Ç;KêÔV¿ãDi3á1{î{ñâÂÃå‹7‡yE;¼7vâ›äÛâÙäÆ´nOÏ'ÓÃMÑÖ .Û¼³)šÎÙÝP'ÿœß’ m3„ã…À8ouãAÞ槽èÿ4nÀ` 6Gq…òĶ¼Xâ.7´»‹1ÿT«˜Âpü¸NÖ¢¶càN¿•¥kõ )[½ÂO¸zü%¨jçÀ€Oˤùrå£öÇUšcgØõÑiMÏOŸ]pÉNàòÝ&ÉÏÞsë2-ÑŠ;«$Ÿ_ÅGï ec-RÐNˆ‰| ñj›–xʹ{õDÎú™Ä_ßÌÕO1¹fN®o/Bß~8›3 …ï†?aLíJXa8óòÍù«g// HëtõDjïjº#b*K›®›½VxyMù¼2lo"ç®ØrÓ¶i±÷/»~(|k³ í}FÈhßïÇðƒM%¸T·<øN»dhÕ”G°\-·È9ûót/féU‰~¦ïQ®Ü!òTCp®ðWUpÐŽ|ª¥ý¶d˜Å²}£QܦóF»µ°3‰GßnrQI„ü8Q›ð1Z£Œ0}æhìBÏ.÷\ú=Àep¨‹%Î c_Ó5þ.|¸&·!ôÛàŠW91@<Üt«I ™Á趎7Y+›?ÃB•|Ù‚j¤xâc½#¡L8,ñt`S¦˜W¢8185Ž¤Ý&ÆÆ oiKÈ–¼oÉ<;æî³ ¢jÝt_'Õd0N“Œ4ݱ(MÛk( ¥¾xvø™Ö‰…ñ‰ döÄ…<Ã÷˜eÂEr €ŒR ØäÅöf5–¦T4»‰Yó\›°lÇÍ»’›<Åpb7orÁb1M2p²lÂ'ÎÉþ蘱5_Haö½º %›<}D!T\i^|¹ˆ)–ÐBAèî"´Á,ù&Êö†÷ŽûŶÕ>F¥k×m×aŽKDA‹˜û¢y8!$D $¾G¡Ö˜L ti˜[–U£w†á~ûˆ‚çmÁÍIŠ›Îe‹§šöfWk†£5@FÍö®ÈŽ}E'€i¤{€Iz„7‘?KÒ×èÈG7/&ƒÒ1ß[ímš™_s£=x0ãÆ ¬ PXÅ(öL™$æ;"ô[z}‚"1T©4ÃðÅ^Û±ps&n ðž;P Þ|£þDjŒŽî!Sd$»·hdõ´J’ÅÅ .òžÃA" 83szñjãïaÆÖø_±FØ endstream endobj 2186 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figs/SchurSolution.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 2243 0 R /BBox [0 0 374 110] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R7 2244 0 R >>/Font << /R8 2245 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 2247 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 2259 0 obj << /Length 3435 /Filter /FlateDecode >> stream xÚÍZY“Û6~÷¯PíËRU ìQådc—73öXž<9yàHÐ Ë©T&³¿~»Ñ ^â\qöx"âhôùuƒbq½‹·/?¿½|ñêJ‰ŸFQ¸¸Ü-©}©Õ"J´¨`q¹]|ö¾={ýi¹RòŠüªÎê»e¤=¹ ÓØ{ÝЗöÆ4†›·Ë@x¾H¯:´yUò Û¼(¨»0Ù–GWôlŽW8v¿ ¼¬ ®ƒ©wU½ÏÊy =2ñny‹ÚlªýÞ”n ˜ÄËç?œ-¾ü'œs?Õ)åöƔ˕ÔÂË[~6ôÌ–Rx¿.¥ö²¼È® ãÛùòC=^ãr™ØóIÙû}VçÿB e ½¼¤þªÞššš­y7¼Œ2ôåüÇó‹OÔÜ‹âÎ5Ë 2 Ù€ó€ôáÛ³õK^½äš›êXli\cZÞð†¿“yáèp¢ÀS­fŽ¤Ã§WoB1PˆÔ—A L´#γ/f úy¹¡±#å‰"?qC3æê®*Š ™zÛ|ƒS:Ý{õFËÁÜU¤ü(I€¢ÐW*¦E~A<™4Ú0õu’ºß¾ÿ‘¶œÞ:Ä+ x^–ùvk¶Ý§ÓÓ*ö¥t;|¸¸|3sl©ü8 ºƒƒRÎ,æÔ“ Í-ø:è}3³LèÇ*tV»ê`ÊýáA¶Ê@ú"Và±L_ß½¿üþìçlòNÃÿWÖ>‰³‰&qVýÆîÐ.Sï®:RÃú.lìE›·758IËDè"Œ­]]í©ÅvžZ_gÎ?Û—Ÿ„ä:Rpn/<šŒ¢ÎÚÜàÈ‹&ìEap³àT>£Î/¨ÝÞd-µà$èòEB4bWyÜ_¡æ`»ÚÑóÄåέ‰Ä6p–Àƈ(µ›lùåhÊ6·AÃ:I¬ 5V/çB¨è *C?Ñcú j%Ÿ®UÿnÕãûË¿¼@½‹`!1æFÉB'‰‡‹ÍþÅçŸÅb ߀d_¥ÉâÖŽÜ/$˜ 4ŠÅ§)xI–±.¤CÞç—3t¯ðëZ½íŒL–»2õ*7Õ7(€0õ¼m”…oµ9Ù_”°²ž³tmídÆkM¨— TA^Í ÅS5c¤Ó…„ß{Ÿ„PÙ5‘Ëz+Ùvè b‡º6Í¡*·yyM½ÃImÌ”pÇc-rÊÚûÇ Ýâ½àႹF`Uk[‘5`¯–ÇárUgå–uõ[„î3v¹¶»æepÛc‹K{ ;‚j‰½5¬½Z܈ðHVt“>®ïEèQÖëk´F8q’x;„zÙ¦­YÚ¨;߃’>³Ê$&82zÍ×yV¶ÔŸäÒ qöúb™Jïõ2Þw?œŠ@ÆI¼=Œ¾Âj ÓJJ²-¼ýþã…š3øtyÆ„…FËð , PãpLØÙë!¬®Žm^šæ/Ζ_P¼V¬ âeÎaŒŠ­]HY©xÌ~PŸ¨»0Ôgx–fcš¦ë¶HÆ6 ÍÎuZ¹BckÀ^¶¦Ü䆧[Ñ+ôônÁÉÚc ø¨×Þ‡’¾C€ªÊ 6wMköè’¤â 6çâË-a߉:A_Òq‰FXkÂØîókÎ!2ö®îhBƘxYðàAÌL¬yÿÚ·©@ÔÃðw`#~ŠÔÝD¶$˜|…±ðØòÜ|GÃòöÏK­=¦üÅá'Þ|Élpc†ËÓ“«`(F K”ÔhÐj¹ÓÂ8é`tå<ì/K? ºX»¾&³è©‚€£»`ÐùûquÒ† §Ÿr¤Ó “Ø“§'&‘Òƒ€ 9»ƒ5%€²4CÅ°¨"0¹D¡«÷uÑxÀ— —À^!€@ñáPäçîÀï_ÔË|Øuí©%^ï00žƒ‚Š“s|~ÇêíFw~5'\j³n ˜° ¶ždU[ƒ-ÍÈ¡»®ëìñí͈%Bu0t) ºìdõ§9ÆFêd ·¦ŒuH+‡0Ž_lµ¬IÀmpæB&c î3G¢ØÚQËIÇ$£¶éG—Þ—m]m³í%=(…d<ûî»÷—gh¾J[‹œ±Ÿô‰ð¦ÂÕ —ûܸ¤g,°N?¬R’è0=fÑ s†>wˆÄ(áǦ@¸†LN2š¸A01 LÓ ì‘)¸}$µKˬWuS5\ÙëŽçýáʬ¸k\µäà6~œl"e˜&]ØJÓädö°Ü¯Yq4ÍÌA4˜JåÆ%„à%0ìqn+hÁÉÈÏ+­#ïS Ö‘ÕÌ› í4m±2h´°®½šã¹ãS¹›­S¢žT8é«0$*ƒ¨ìö ‚ÔrR¯šnÚSz¨Í&o:âQ[«b wÚTøÀW_/jÜݽ¬ßždÀ]pÄNÎRâ“3N=}ìG:í®|¶v­ÏÈ‘F| tê‚=U:gÍ:ÒB&ØÓÕ—„ÿ%cù‡Ùe üêÍY<$QCͳ&$z&73Êô &0ì>‹á‡üY›¢?;¸Atyì¸a—9Édx'†óD™C¼‹Ÿ ñÇk€Àû|WºÒB^äíÝœÉCÒÜgyÀø@ƺÏNc¥È)aÃU°^6Fq0µË“°ŸËÈÈ=|¥ 0¶¬¡áŒœGΘ~nŒyûV|„Q<[¿{ÿæÃ[dd>f;yã´C7Xj‡”è½ÍQ ]¡Å¥±Á|èÁ¶ÔpÄÁŽ,`oÞPçæpÙ"úÃ×¼”ì@WðI=C‰h¹5f¦ttRpXu¾qö‹'~û”ö#ÑÁµ.6ëǸé¹ì˜ö7Ú=`„mÛg;¶:]ÛËŠÎŒM‘ïóràø‡¡ðØðL—*à›HON¨ä£ŠYo4wÄ9³R  † µÆÉ=æ<åbíh³¢¢A£ÇJ'üh?:VLd ¼ÉCH2“ ƒE¿à¶:’Âû ²á+DˆŒ½t£ŸÎ8­`zÇ,t¬³ g”Øc-EPi˜O¤“ȸ:c-omí­˜ô.m.‹_;¢Œ•ítîÉèµi;öÂۦηt\cq59C=h§5€:"&ö#®Šj󥙿 Ë77tf'åls“ªB[ÇH•¯yhÆ}}A _×ÄlV•°ûãšž'6‹ A8¯ê‘ˆMÁ…Û•J(#"yÚJ×ý o,&ÂôþÔ²@<6“Râ &#_ny:G 7Ž”9Ý7¤àf:]¥rÙô5¨×ß9¿wn(F€V÷Ü{pn¨mÉõ¥,+`ñ_Ìšb!Alµˆt6Ô%Ó1kšÊj‡de“‚” l9Ï®éž;7•ÙáÞ˜6nrƒ¥9ì¶%Õݱiƒ³V=7æ˜ùµP§¼ Ué½(˜°+Ãâ#IÏíæ å7U±E…uÉ}ãÛfBñœ“#1Å~Ø'ý_fh!Ìô53¦\øIã8¢ÆØ)ˆtË@>Ó-6Ü/ñ£0YŒ†žîj¡»ÿ ¾"Hf½!Þi¥ñ þk`;iU€jyöMïf&µW͵×j¯zZ{Õ\{Õ®öªOKF0ù3G%TjÝ°±ÆœÅ“b’Åx?Ï\r¤±/¼ìP~Qê+n9RT(Z) ÕãõÚþ††+~褃Ð;ËlÙæÚ&c8ññ%g¢~ ŸìŠS*3CÖ±É(ûjì@‡ÆMŒ‡ŽÂ&jÚÍ£Äy*¶ »3ö£ýŒ¡àAX„8SÒ‘ƒö¹œ»®<©êjpE®î-÷då 怘Ù+nvÕ€gkÍ|Pv{`vZóo2V걉96×­dCæÖ˜å}À9aBõ³Ð]&„ˆg!jPŸÅ¦¿½¤[¦  £Oມу%m蠾–ڱ{×´Œƒ`”ÆJ<¤ÿW¨¯ûÅîϦ½?´ÒnÒ99UÎŽm…¸c“ÑÏ#˜ÖàÖyzpêjÒ¸ 5=$îVvÂLÖûIiµ-í$ϨH©?´"u§Ò!}Ž Ï©v~Ð×±g ƒÃĸ^ƒôc.†=èZ)@¦ÂO´üOTÏ&ä¯Ö¤RN‹iDM¾óÖãKÚ¾À/fÝK¦÷Tô¨†?Cuê `0~'Ý Üžœ(1N†ãÂÛßgNáÀñ„âÿö‘;¥Ôç]ÅŽÏAG»Ø?ñº˜`EâþŠÍÔùf‹T/ž¢‰èw ÇU©¯¨£ùƒJÚTÜ£ÌÚÅ[oQ> stream xÚ½XKsÛ6¾çWð’iZ!ßÌLŽÇNÜqìT’{Iz€(Hâ”"U>ì$¿¾»X€‰v&­gs|× "Ÿq—[˵õq¢ÏÜéŒÛ¶=ys=ŸÎßžM}hê×Ó™ËíIU‹:­ê4©¦,}uéÆVJ•ÚÖŒ‡ÌæZÝr'ûH^ɬ˜:þäºÛ;÷SîOdEC;ŸÕHÒÔi‘ÓpïdÕ/e&j¹¦N]èÖÙZ¿‘¢nJ=º–UR¦+³+Õª2QçÀÀe6ãðï[%úÎtæo_XÕb—ñP¯$çÂM9ó­Å¡Í•‡]æùlÿºäÙào: ÐÍr›æyšo©[lô0ÚBÿÚØŸýÓšb9,9ÎYÌñߧj³ØIÅBÖ5Xª-Ù¥¶5+’?I¼.fs‘ëÞ'Û·á"Ðp^©ÿ¶n;»~{;¿Z¾{OÝówgó³óåÅüj±¼:_ÐIápÿï¢LE^Ó¦¦’k€=w@¾\œß¸åVÖG1[u©Ò¯²sÆ=ª_e²óÈ/Ôp'Òá¥ÆçÎØióùoúˆC)“´RÃ(—‡*ÍŠüT7³/fv ôÍÌ¥2¢o÷ûÀ*½qQ±©eyä’Hê¢L¿ óо'ø†ï¦Ù¯ÌÑ'/iSy] \yáãnY,Ï–.jñín?\ÌaÆtÏoïn–]n?œ«PÕéM™d‹óvþ$ØóCçâ'îv;Í™ý²5Ê~Ô¹Ù ÞË‘ã_’øÔÑœyít»4˜YÔ?s#ƸÚc¡ÿ1^äëE‰jŽ–æh1Z´Òê4k•òP”uu”d6E¦“™âoJ)@‹{…ò׃,ñêÒwz'Ï8ã04÷Xìytô'û(³¨ŒÒ퉙Å01ÎT#× <æÃ#Õ;€Ê|NÜÂõ=f™Hṡ®ïª|ˆSÏ·¸i,þ z"”ì’{‰(Ãõ÷8FÆkK0À8£üŠ*Ò8²—õ®XÓàNL[+£Ù•”D%3}Ñ°Óý!“{™CÀ¨vyG±ê5õl4¶_ Ô-€c³tŸæ¢üBzSÕÖ$hùTmh•Ež}阡‹€l·29æ(ŠŽË€›EE®ê¬,Ьût} r®í@Í}èž•íFžw , z@t£Â—.Ü"Š'ïïÞX !˜+’5-b sÒˆ>E<ÝG&r¸1©‘)çCÏ<^cË+-ò Úé¾ÙSGä zþd/>w£œž1E4¢”Ž« GÉ·Z¯údÛ•¶ÕX¸âtÇlÊ'¬h¨Þ‰š=ÈRëÙMÞí¡óƒ,‘€2Ë ©zÀ¢‰l샎ÞWOƒ‰pñï¡4VÊœ"'„ï(`{ †7'‡ÎÄ´¿ÐÕ§AíÒFRW±L·…RV»"[SWq¨’Ta‹BRì!(nìÔ¤O©Z¡JÛ9…8€'8¢>á J³ÄÃ.MvÃ7]ÉÚðFY4ÛÝ1‰ô#Á#Hï?œß,¯1õ†&ãyÔ Y`ûfu%QYhD)€q}OGßqB ÿ;âÿœRm„IìùqŸI|xøy%†ð#ÞÝØkk=”ÕGÎb8!äg˜h* -ˆƒˆÒ®aôpÿ TÄ#Ú’A%¬ ßE¬ŠÚ\W¿c„ú @=Jè šo9Çè{¥RþÕ¤¥Ê`´£JÀ@ýÅ@Gëtº9òa ‰S>®ÒìÑíw{|‹¥1m¼Fÿö@øý· ò•ô˜‚€…¡×“kò?J¦Uï…\ce¼/¶P·H³C‘b¬Ô,øU!Çd}ÔÀ:ÂG?aˆd—öJ”㣻˜êªðö>­t©sU?^$ÐÈNšED5È ¥ÜÀTžÈÿ-z#ßc/Š—A*pãÀ¤LK$ B› @6CYåhO§f»À©þZÕ[(­¾th ‹1= 8Õ‹'‡PtâCZïú¿QÁ®1vvÜýlÖÔ°ŠÊ?è¥F3Ð[6QÑ„ƒ¯Ô^Š¤³D½Sm4òÐ[/ªx£ftëˆyÁQ y§yTÕ,ªP L•ä÷*b7âÝ<À¾ÑVáªT·uº× ( £‚Sâ0dî&ÓõÙªUªTªŠ#“àN ¸JlMüôÇßàE¶Võ9 }Õž~yPŽß À¶÷;kä°«½¾ýC«;Øs±|ñ7"dM endstream endobj 2304 0 obj << /Length 2040 /Filter /FlateDecode >> stream xÚÕZKÛ6¾ï¯Ð¥€ ¬´$õ°T ‡nÐ ’¦M¶§¤­D¯‰J¢KÊÙl~}‡/½,k4݃!ZŽ8ïC!ïÁCÞ¯WÈ^oï®n^FÄÃQF ñîÖ&q@âÐKÒ8À!öîJïã"Yú!´xÁ›V,qºàÕÒ'1Zls‘×´¥B.ÿº{}ó2̼4È’$R¬ç¸§™¼k–~Hð‚.q¼øÂZõ-Ö‚×æ~»¡fÀÖ²¼b_ó–-ñ‚ÛyE^Ufô ÅH½ä@†_ì %ûóþW%,$ ð*½”×ïní|£‡›—ñˆ: ŽñO3¢a (tŸI0, _Ãú´—¤PúâvÕ]iÉsa©$µºh¹¹QÒõÁ®jÍÏK/òjGe°ôcB¯Öv¼ Vçù8Qša€‚,¶ßI*€‘Å#“*ÍX¿®ðÔ zîæ?®v^»É7²ÔƒÅI%/Núg‚Ê-oJÖ<˜[4Àgf™Õ»z«=æê—»«®°²‡½(L‚l{Iﯨ¯>þ…¼¾ÆYê=jÒÚ#A’Á ò>\ýaÜxdŸ(Ì‚$QœÂ µhu€~xõâ·»7fySÝ…àþ&cÝX"ŽI€³•—D!8Tø–ˆAÈ4UœõK4+TÑ%7|W•f|OÍô«ÜE óu«ì¤†í†I3²Ácþ˜Ñ´MÇgÍu³è”NYH]7¬ØôT±O–‘› îS&4TÁ ºXgŸ€îî«%.ƒØæWMKܺ‹S ž?ËDq–áo`¢8ƒ{ˆô&êÄÐÂg.#7Û— D š•£r6˧üV«ºSO.DnõÎ×æZ²š6’q;%BÁ4“ Wå'I‚ ?@¬lºBx5št,Ž–Ÿq:–Q¥búF ½F9ñ3¾k·;ë½²4¯Í\Ò ¨nXS)ó*ŠgäCgQô}¤#ßNº’å —-+¬³ °8dÊk7 žz*¯'Aû¨3®htV(çܺ ¿n*~ŸwIn×  Þ\»— xLY /ð ;xž%^¤ÈBø»£ÚÄ«, °Eð¹­âð;A#tH¡ùv[±=}2@¾j×Û•ú?!D Я'‘•»<ן¾—üøyÕC'p•wÂt ³Ù‰—’09œŒé&PŸ‹’Šù0®ü“l©~qþjŽÃ˹Ú؆«˜¬ÇI½£œ[çnxyvh‹£S¤¢€ðT¨Ü–±`®¤ã¢Ö‘Sðöº÷q è¸ø»w‰m^œ_ é3ݺ/‡=¹£)!Ò¡*. TŒNˆw ŸZ ?›è“q5ÈÖ—!A‡­ u§fûæ´h[‹’6(£ I5çqÍ6­¿é6(’•°«Ç'ëbä¶æQÌTÜ Õ°îö§bÖÓ(i ¤Lí/Z.ί(rbd_pAo`Çïóµ÷šz÷îE¯ÓGVRêV¿¾w^YtnÌ»,4¼•²Ø`•Ì¶Äՠο°zW›?\ÄÐiÒ PÔ´æâÉ<ÔÕ®oMf]Æ‹üöÉd ÍÃlˆ'g!I‚8éšoÿ|ûû‡äí;ºQû»p@Š6/TJwEî@½Ú °Dä~VcZ¸UÀ½û¹ÐüDHØì\_|k19D²C)‚«[£³ =ß] 3m?³Î¥þoĆ©b.îà†\Í0—AFÚhÊÁL…ƒ]ƒCÓà…ŽaýzÉg9XÕªi¤£‡÷ù`yr°¹SŠÁÎìøVx»é¡ßzÔþ¸|˜°:1€î!C €«ÉqCäW殺m«‹ÆésñÀ㆚óÑaKkÒ˜r‚»MÏp‹žï§š¾K>Úº¾1$]…Ãhyv%ÍCâ0mà¯M2d¨¸=Oq^¹‘¹ÞÛYêhqüÄBî÷p¡ÞYU¾®Ž0MÐrWtì‡}Ås“ “¤úØ /·´`JÈ®­ãŽ~çt§ë³{L¸90 }¦§FÂ$ÓÕ´­FŽµÕ`AÈБt@«¸ûÀÏ xSÜè9Íø?{`]óûé$‰þJåûšïðgS2ŽäÞ¡ym¥æi|{ƒ"‡€pÇ6»>ðûí×B>·'“#*IÍl íY••“V ’é±$8_þOJ O츓7í\\w$<õ8 ä 4ì^öÍ«@„¾éFïóæï~óxûæ}¿y¨èBgÖ&ŸgøNáJ‚Ň¾`ØûŒ(Ãhú¹Æúœ!˜XÁY0A“ÕF8¶ñû2…WJÉî’úl>ÚÚ_wl¾¼±ëþqâ,@š)IÌÁK¬ ᫯v2ë,ñx?óËÝÕ¿£iÞ¼ endstream endobj 2210 0 obj << /Type /ObjStm /N 100 /First 1008 /Length 3212 /Filter /FlateDecode >> stream xÚ½[msS7þî_¡o…íTWGG¯ Ó „f' ™˜mÙB?ç.ñblj;m·¿~Ÿ#[NÜ:Ž 7‚%_Ý£GGç]Š¥è•Q–bPÄ$¨lpÒHÊ™ò(+ÏdTˆ, RÉdiX•ŒI¬ÈD+-§È÷Ðò éËÓ¨Èá?´’¢@IZYan™(…ïåÝ †ä,]/“fLhå?ÊìlyÃ+ë½ÃCB(ä“õÒùìeŽœ“Á aË¥EŠ9DiYÅNHY¬…ƒ)〇)`|Ä*HHrôYFáa*Ô°dÎàZ¬ûÒrÊyg¥åÑŠ¥”K^Z†•'*³:å­pž&Ó³–¬òž a\(oÆÅT¾Ã¸lå *˜ò.Ha!ZIìX® ® Åàà ã,aË,vTHA([V!ç2ΩXvÝb•±l»©ÈÂLk£ŠÞ–qIÅ º1™Š¹`á" ²¶*ÙBY%‚LOÞ$iyðUvÜBšR2å]ð:³ÌÁIee˜˜.ÀZ ‚]p*³É=Æ[™=ö|„蕹2ZNcÓs(o:´V{…§Ë–Œ‰ò¥'4…íhZ4ÙÉÄ^„Ø%È•L2ÁÊ0D»ð5…$B‚‘É,“¡•“ { tËdQšQx¤¹>H —];‰¼‘­ P  &!Ê®…™ á¡"ˆØ (;ˆ&æO…„°dYô“€C&‹¢‰KàÀA6eß{ü¸×¼úߧV5O&“é¢×ô/ß-Jÿx4ùÐkžNgçíìM0?7ß5Gͳ7T:½æ¬.ÔGA{(*”B¨©óF'ì'¯ÉaØõø±júªy1}5UÍzpöüàì»þCõí·=üûrXºfh{Ö…mFç :ÌÌÙŠá¸kä²&±>A3$¶F{l‰ACœ¶b8zvòêøí¢·;daį€@°´˜¡=p˜NqXÒAL¯Ç§È_´šDïúÆï’;4¯°ƒhl»Äá°ba8jëà ,ÎE ·q?ŠâãR6l'þMîÀþBoø~ô„‰5¿¸ÄÀ 'r²ÄüòÝ/¦-F¥Ã=á¬ag"è?±Þƒ~Ü ¥ýårP€ÀÔP‡ÖÃ:]|DŠ:Š‡ƒÐ†§’£ND»¤Ô†Nµ%YL_Œ–ÖÆLt7¥­(þ3z9k5w(!ÐL#»‹ê”9"íÄëzôw*¬íÔ‚9Ì/ñi…!¸pp;`wª)õúü+áÜ1ÿI· "¦'(I 1$Hè¥5uCY¡&]Ú§%Ù¨ˆ8ˆi·;݉hpb8^qP„Õ;œüqv1ïP:(éŒ,i Á‰½B·òé°h U@w úŸ³yÛeà%ŽCZ˜JäÈ£´d‰Gëy{ôw4ë‡5Q‡’í®p öáv§‹Y‡ õEwÅ f‹~Ú b‹ÎÚ.­yEIª¬–d‹3¬ŠXw‚O¹!8ïVN‘œi¤ƒ™à±½$öˆC‘aôÃö€¸?ú£í/.gÝKi2Zê2„% ÅÕÖ܇1G¶WÒ´Õül³.‰õÍóo‰ü$¬7„ÏTóúß?)ÑxT´¤&—ãñÏ7D¢]FØFZ~Ëh„è’}{¨Pƃ[FGDkRR‚Î|8,ÊÊ‘ò#X¾uè :¶v$Äp«òç@±vŒ’nÙA²ïS}ÇKÕ&­:h 8XuXÞYS#}:˜·EšOú'ý×_¿}lçßœM?&Kí8h— Ŭ¥@YÄeITcÐh6_<»Ìàà{Íñ`Õɾ×ü8:_\ˆTycÊ϶¿>¸u[j©ò#²Zì“’´‹ËÖÕïb‘•:Úûpí»åg}·P7bãžO†ÓóÑä=–9š<™ÌGõ‹k–RÖD›\Û\ÿ’'ƒíÍÜzZ” ó~CR"… 1Àáxð~®Ð&(Û|(Ú‡'ØÑÁ§ïÚÑû‹UWf“gòz¯9Z Æ£á“É{ȃÔEûñ©3BŒFó9àËALÛñ yÚR}Fà8þ‹‘t‚ªzdî ycÉàá!½E?ß“X0‚‡HW œqàíq›"y™Ïþ "t‚Œì‚Ñuü+báÄŒhNI±—Jµ@íøö2W—¥¨jÉLQ¦”P*÷.£ŸîQB&–ÓÆ ÄåPj»€td£Î}FL.G]L±±KA{{ojƒ¤Šþ E^ ê]ç&HNåx9xíD2'-‡ŠRóáví² #XCqÞA`ÓN(w# Ø´â‘®ÄI»€t_ª‡¡/P·Ãxj9o—º¨ót_Õ` +…ÄÙÙ¨ ¬˜ê±h.CƒiûyÁÑ|:>ž;³Îð¬„#˜‰Âš›Aô;Æà\ˆZVIªÃ´›+Éìô€±UÈÁ¯‘²|bíÅ~X)º=p¾H:Œ¢ ;žuD6Ì àU]4åÔ‘Ô%m¯. G‹VÿÖŽæïÚá‡vö¨S<A†£‚z‚]2:ÉÑômxƒwïÆ¿="ßeÉ š“0·ÔñãòHšåj xí­'mr–Þ¡ÁÁf¹;ñY®A°ôð=.î2%²•£Vx8uK`K PîŽè÷«ú.Y äV T(¹~é‘3r4Dû"²]Þ€lÈÝ+ȯ1\® ”[G@h¼ÝQ—e——;¬T²¥ˆ‡O+w­ Ý9îШƒ—rt%!Í3¶@‘ÃY‡l7ºʧví鉮\{ v)¥ÛF¯Nå˜Dû¶ð_R1úÛÇŒîdóÌñºo¹ù˜qódñÊë|¶/ 鯾$„Ï÷%¾³…N½‚óÐ6&ä%XãB‚õA¼±#L÷œÇ˜ …’Ï$œbŒmFökJ6üwÁ1 ûž¨‡m'êrä’ù&yÜ´½„ósʼn—çÉâÄÆ~¾8ňĈĈĈĈÄzÖ«ÆzÖkˆkˆ“*åT)§J9UÊ©RN•rª”S¥œ*åT)çJ9WʹRΕr®”s¥œ+å\)çJ9¯(³1µA]*"8˜3†r!¸_ÆBJå²’n•ç¾|Ú}”ãáÈ l%¹žaÑÛúJ›þÑeæ»ÆLÈ5®Š#:¹¿´ßù}‚k0äÐ&åÝ0ÜÀ`,ò¹Æá`ïn¸~ºÆáïÁIËïæTVŠY´G¨8þ¿jR¼ endstream endobj 2353 0 obj << /Length 2026 /Filter /FlateDecode >> stream xÚíY[ÛÆ~ß_ÁG °&sç°€ 8‰SĶîFèCìÞßWi]§{2º èbƒg×LEðËI ÜÙçÿz‚sŽMŒŒÏ2yb7(Íý±±ŒÃº©Òä0¦µ§YÓÍŒ0¥áW‘Xº¿Oo“cÞ¸{?%ù1]’±!J³žÆµ`4ÔîÌ{ªhÝ$Å>©öêPš–:ØÃܵrhëˆÅÁšsP¢v·ÿøÝõæ'¼”÷§ÆÄ"„l‰9-›îu7¾-+7ØgÉ]QÖM¶sß÷UV4Yq÷¢=“4®Ö~X󶲮“ª€½5YSºLøœÉ´5œXxfß® P\×Ù6O*¨ØV¡CLls$WM —#5ÿAÞ…Îõgð.àcbDÿ£_ì2â¿ä2wy¹M¼&³¦à#eádWæyºkÒÖý‹ÉõÀÙ¾ºÈWù?ŒAòq–ÊUøiÅT˜zí–·ãh3ñ°´ª`(iøbk¦ah¿¾F!°Ðër 0Íοœ!Œe¤Á‹jì:Ìí_¼ýïEþ0ÔS÷¼Ô»²UíÔká{Ƨ¹üÌ3¯ñòzn³Lä€ïfÅ4a¹„ Ï­ø,§“Ÿv ˆhW›´j®7Ϻwβà{JyU7í1ÏCZ4UÖ©Ì»JRUÉCm=ð4cS£‹‰‰‘ÈÁêÔçpQ> —†r¹›Êo6Ça2+À>_ÌQë>©’CŠ‚=Ãý²¼×cz™ixZ¹ê"ÈÝ•`1e>^p•ý>l³°2ˆiêÅH pKTP¡Û«`Üüóq[CjÓ)MNøÄðFö…à+A-^/o?$õ’*`oÌÄDÉng3Ÿ1<,dZåôž·?V]ÜéN$E’?Ôm»oi¹„¤nÌÉ(ŒHÍÁ̪,¯úðeŒ†àÏnÀ ‚ݧ2‡ ?sþc| €HÈðúžgáõõ/î"‹.•·s·n‚…Ûd÷Ñ[çÞ-íÊÃ=8á6˳æ÷) ìÇw3ß|# 1ÄQ°fÀ$vtàÃ( ×›«]¡§Ð€Lk„ e„Ò8Ø®ÞýJƒ=,¾‹± ~³[˜õi NÈ™>ñôõëŸV17«HbR‰ó3o77ÞÂy$ •jlá~×?W`Ñá«›iî±À§à(F<¦„ª§Ø…ð 6Á †q6¢ç"XÒœD”Ÿƒ¥Gg·ÁZõÈ£gÒ¨€úo‚Üg>€®Ã â¯à¼ Xv|Dôƽ[¿êC˜ºß¦= UÍq×+ÿ‰¾WGÕîá ¯²@‰-xØÅ_œw¢;,ŽÇ&àÐPHíÐFÊN½rßÙ­ûtÁ ck7·ÃÄ.ɳ[)ÀÒÑ)²péâÀŒÇ†¿m`&l)4û‡+·Ñʾ‘dŸŽ9J5c©Â·F,—£ ‰´¸0Pø<É $ ÊÝ„þÙ#0Ñi Y 4 iÆ3!¸"lFÊ´wŸw À«ç BkdÔŒ ÿú"ºKDÁžC’ ivêõ%x‡¤*óos¨P¤9aÖýÀœ#ÁDç~¸X{|לdäMܸ+öP,VÙvÅixìšvOÏŠ/É‹-x:´¹°òNóôîg›‘èAT¦[ÅÙ.ë‡Pç@g·~µ­`Ñ–Ì0åÒ_˜¸;ÎÝ¿ÑÝqÛ$–âÒ4–.Áè#")xœ¼šƒÝ‰H?B8¤ÔÝÄ"=¥Ï¥rqRåÁ LˆI(~U`àë‘´à[)Ÿ°]æ‚ò‰¦(¶ð:cMü6zQÕEÇ4<¥ßÉmÛûú²-\?›¥øÛGdݤyÏ Ôþ¶Z²õ?¦ØKÉ TÑ\Í’•Sz„|H@J¶«½™9ÉÃ)^ æ‰iÆu“’êãÍŒ"µŒÉ6G1Þ5p°_An’Ûÿ?É3ÀD!8à5rªø¾û0Ðr½Í0/1,ÄVjãζbpE5'y)A3O&YM85çiüÍÑŒÒûÆ}aç"„ˆ Ñ·Æ•ûÏ ²›¶fÎZnë2Ómû0ÞIŽha\®'uZ÷x1i“¾µö©cnèB ;B[|™ÅC(JÌLžÏM~ZÀ}}£ð%÷ Iá²\$Æ÷XHŒªͲ> stream xÚÕ[Ý“ã4ß¿"/W•©šh­o›+€c)(`]Žºâxð$ž‰lg—᯿nµdËŽ“™Ì^ÁÝÃŒ­K­îV÷¯[J²¸[$‹/^$þùéÛ/_)±HYfŒZ¼½]p¡™ÐraR͸䋷›ÅÏË/?ûöí×ÿNtbà¿úåíW/_É,úJ)–d†tÝ÷E³;tE{µ™\v÷¾ˆå.ïšòwzïjjÌ©øGÑÔ«Û¦(¨vSæwu•o©1¯6/ë†ZÚu¾õÃùqåh\$²…a€DXdÂ8üéEƒ« …¾x±øÙ}øæpÓ뮬+úX2á?$îøn0ÿcã­<VûäÜr¥bJñÐÿqó0™Žƒeí¿þáõOÓÙÓ^àã©=«½°ßåÛCÑÎh§¶,1|PΑEZiàºЀM£ÖfùmMëz{ØyCGö?ï®`£ãìúÞíÁ7lÆ6þ­À dÚK‘Ÿ™ñ-Z,™™àf6X²½Àw0‹Ô…žØXáþ} X¯¦,|ˆ]ËÎW ÎKa„½ç-»ZY Ìa—ï®ØÇi7 g]âÀGžecǹ7´ŸX}*nÊ®Éo{Ûòb­U?jÄ3ñ(ÏLÖ‹ÆÉ+P.ølë{x³à@l÷ <*„Û®]–úUSÑ ÷ŽxˆÍ·ô¤f›Ä’ƒê^rDÎ)®íòßËðTºú5 “.«Ã®hʵãgL[KeÇVèFž+šò®$öC5ÍŽ6Ë*ç½NØ-•€½Òf¡b6`·T@ÑH:•‘ÝBvMDîÎ7žì}S£¿+7äsÀÉŒI¥Çl:r쇶hŽ½xß`CÕ>ìvP³¦ Ç›uÑ^iñ„³Lò T¶È ƒÏQy¡² T¦KûÙœÌq±E^ÞݶTØÙÃÝt„gÓ[¼|‘t¹qˆX¥œ›O®VÚòå÷þ½Ð,³Öø¸Úe• 7<\ïõL@5xŒ¨ÓÓ³`Ò,?ÝéJЪA~­r)}® Д´?ˆtCHýlÝÐ)3\\†ËìƒÂðD_¢ãé\Ô‹wÊÜóúUuå­›ÉXªÍÐHm 4RsZi`ŒÌö©¤OfÄŸäèÍ:Âdáa2Î#¢t®â´|¥ö@ØMáYl ãSÿ9hh&7gÀЀ$Û`’cL8¢'|Ü\È( ·œ:Oâ"ײ½Au÷;LGAâƆHÜXŒÅe7>;ê£]¬â>‚Ÿ ‰³‡Jx*‘~PL¤™’4’ÙDþˆH²Tʱ°íašS¢ÝPB¶GH?X€Œ `áCC ¬ç•([u/«ý¡£×>wJÒ;°)* î¦Ü–Ý©±m9%ñA®'\‹°Mœ¼šrù¡«a 8a8XXß×mQ[[ßvﯸK‘yÀÈÓ£ìäkèâMùĺ o¤6EN%Ö¶T™ ­LÔòuEõõ¡#VCÛmSï¨Ö[F« ”œš\šg––eIïB¾üöÕë/ÜI‡|ì¤CƒHTïïëíÆ“á©#q¤z:òý~[ŠRÜ_ãÊ(eÀ‡$yÜõÎåÿq zD·û°9ä¸gÓÎþbEÚeÆÉÅAM¾yW’2Ê `£;kÀŠ©ù;åTβQüŠ]Þ;?â>  7J†7žÆȞ̬(¬î#~<Ö©8­Nèã.DZ`c+¡Ú‡›.¶#R±ï¬‡Û7V•{…1ªº›Ì¯ê0„1zy=”3KÙ×e…Îí2 †šÛ³×xÆÝ¡&~¸I?àâÏÀaiížh‰žvqM±Õ±wËôùO¾ÜäÞPM{u)7Ôp¾m©%§šµ;ÔÁ ¥3d“Ã>àfÚûðo~üæ»7s773°Â=A.x™+>œ`|õúÓs«ç†ñÈÕ¬B¤€é!hý2ÝõQ¯$µ_i.µa’OÐåXûT•òOþΩq!ïc/8À€áF÷lác¼g{òìq—0z_Ò~²| '(9åÝZŸ#s»ój@ÞºÌÃݵYÃuê&ÜÑ58ºn5N¼ bñÙŠñA…b\ç¾^m’è H±tkÈ â²=ß;û)–;ê/Òø` ï^Š)¶™ !ŸíU©œ…!…à s7Ã53€*bÂÚp¹x’šߊ ùÄ!s3Ü éïe°p¸Âl´Éø8Yûº¢|ÄÝ•»~Rxhˆ•6†ŽØç:beœ˜Ñ”ŠÅëóØQ$‚%ÃYÑÿ v„0ƒë¿;Žæ}<%¥:CÈ3î$j´?EÀŽJvŒ/1v ÍÂ?¥*ÿÔþiü“‚»°£™`G+Â=ƒgáK ®±ê@pÆß”ÀçCÈ]YùszÈ&¤u'¦§)Ö5hgµ —ÑÇIØǽlüÕbèi‘ ºšˆ™A,KŽ™œA›LMÎb§’Ó }q‚’ô ”d“ANS²÷ÉS/ø ){çq\Û#¬LÐÙ‹ ?mQ¹û¤¶ . Ÿ ³Ü<%Ü>>ÐI¿ÞGï ¹CÿÉO_`fê1W‘Ùôdõ–.œ@à\»Ë—Þåå¶õþÕØtù^E/¨avz/J:©Á¯è–Š\n‹n,iÀS`I&lˆ Ûb[¸+fV†k5‘78l´åwÔ„Lû9ÓXSÁu¤e¼uÒ«¡õ!Œ_OØ>½-9gÚè³'1ǔȌéóÃÌ¥õ’á6^–‘}K‚ó„ LAÕ¯U;â}K „>F}û°'ñpêné÷WÙÒñò÷|·ßÔ#¯¨!?ÜabßÙ3¨nÚ®ØQ®ïý}éî—GcæÄö|šZ¨šŽÃêX‡è<… “j)¢Ã†@`4¾­×¿ö7V|Ðõ}Ðïþ”O†Õ‹,»âêçÅ?°…aÎ@ À]j(”vûøù‚M£ $ýÄH2m{ ݲaµˆyIi%¥uÆwÜÆ@x> stream xÚÕ[[wã¶~ß_¡Gùtã"=yH÷’8Í^²vzN›ä’h‹]ITHÊŽóë;€WÑ´emOÚ‡]‚0f3ß Ætr3¡“o_ÐðüÛÕ‹ó·’O"bµ–“«ë ãŠp%&:R„ 6¹ZN~ž^¼zõÃ/TQÿ±³_¯¾?+lk–DòHºá‹l³Û—Iq6ãJMc|èiq¿9cÓMRæéÂ÷ì’|³/ã2Ͷ~$~!Ë—Ižno܇\o™ùç2)aBºMüìr•øþ]zÆÕôöŒÓiVú.G¤=[Oçaô¾H–¾uUC€li2 »˜1J¬²~/×gŒNãE™åéõRé4 ÏE\$¾•]ûg‘ü¶O¶e¯ý{¼×÷EZø7Ü"~ $@ ƒj’£(ª—Oߢ@h[ JÉŠ·µ(xTÉ¢–f_(‘¬Ê× Ç“³™€ ]&É#«˜üìÖ{¹ŸÉ¢Ù· ¼óÉ0,Þ.ŸGOÙ£7%ŽfoºÍ•‹`)À–ÓÄrî÷øq…â8TOΈe5 ¿ò<ˆ‹¤Ú@§ó{ÿ jE§«¬(ÏêÍyo×aÔr:ÚÌpŸÔ]±q¢­®¾ÙÒŠÃå KeÕЮÂìVµ†¯;¨:F=Cu%º^û×þóAž" gRƒp$±"Èæ,E:_‡ýÜÆyÃ[qçùKq_Ô§KÂïÙú6Yð‹qAËŠ,)̃ÓxœÇ2Жvüˆ µe-1Ìœ¢Š N´õ”Pzâ!S¶9ežSÛ¼p|Í3ô.€ UJL/êáq…XàÈ;ã` ¸2]Ì1Ì1<-‘Š&*Š`õÑ cV#=%”žÂ1NŒ¨=èfï|#¨™ƒUðŒ×ëlGgé_{ç—ؼ)Ž–Óæ'¯hŽÈ£(¢¿ ~Ê>bÌE¤ ${:ßRàì(¾u4 MFŠã%nXû÷¯«7BQ:}l °¤â4jãzÙpÎáU.ÑÆå ëÙeEêñ• Ò¡R|Þ¢aþÖ÷¤áz­§âÀ† gC¼êKýêc?LÊ}óa2Œ+ð013Í3¤rw¾ÈÖûÍÖÛnÅÚ °„’µF¥CæD¦f]o¸¨ô&Ý"ÊÆ70Ûyú{` øtr3µÈò<)vÙvL® èÀJÐ?8½LèGÀz9+Œi€õùêÇáØêÈÒ’ ~ݦ†¼yâ$]AbÏSÒs«LZØëz'~Šc}›®×m—ú¶µÄÇý£ô+#+¸|õñäÕ«ï/pOk‚!ž²„3>$¢A‹ì(hㇱ5|û$ØÅ‹ÏñMr¸ÿÐÂÌ]ž¸sšfû¢ŠJÒmQ‚!~0¤ –#<¹wiY”yl7†;ᛦ/yHª|`»aûÇŸ^Çp¨ì0œÑ1ŽG:<‘ãR<„ýéL–`$P‹ÚLV#L®¿û.)ÓâHý@Á»ìf±;z²‚Ëÿ?×à’º¬×_2b¸KËUX¾Ì`žÏ„Ñéoû¸HgËd[­78¥lHÊvÊäÀ£ÍD2j%ÍØvš5 ˧‹U–.ßvÁ<½ó…F‘]—ÎåÇyè©2"Š*ƒ¬(|‡Kbx0ƒ•´èAkÐ8BÉ.Á„ ¶Š ßE×±³¶ëØ«„!@É+å*üÛ&^&¾#žñ (]#œ"­ªø»Û™”¢®9]Þï*¸*léIqH¢îïÑâÓí~3G…t?^»ÐîâëÀ¢ »°¨ZCÞäƒY.vëwÁ°×¢üõ~ §Ýùurï×e+ðÊöümÇÝ.fíìi·—óAÊ顬@ ÞæÁÅSÊ@qž®Óò~+Jb¬è-©—¶îœ•MoAkÖÀý®Ý©É.ÎÑÖ ¦q«'l­H¶ÏMÏq”vdNOíòãRs‘ºRÿ”¬ý}»dÜóíxƇR/ÃVö%2pc»~l3FÅE/›8ÿ<´fÁˆ0±lúæ7ëdow«ªåÕÀú X²ï…'{ë’8õ6]:ÎYŸCÞÌuþ'E´E³¥L¶Žñ¬ÏÊ8ÒI~åOƒlx 1_ØDÇŠ€¸¨n®,HmzZý-.>ˇRײ}¼ã¢H6óu'(X$­ëŒE²-½Æ¬Á0V©ò`²–iãçh}÷ aµ„»™ ͈D´"ÒŽEHL[¢\¢$u… 1±¢Ð3BMøy4‰ôŠªGÏ¥ T4ç’6v'®bœÚ¾d;”Mß”8*RÅúœÝCß#2„“!kË’¬“ H©RZ†’àã °§TŒŠBCTñI`vÂrãòsJ‹?W,8l™p#tKøBÝÏÑ´¦|·sïØ0áÝ!e!Î÷(¯!_ÍöþÄhzWŒë$^zëIŸ–ˆ€æÖ¿·})¼V˜ Ûó¤¼Kœ½‚ñÃw[ ¸¦»X­Õ FSßïN)<7ÿêTHêà¨Þ@Òyør…7M}ôñçÅõƒˆ=.>‡©×ƒ­±Y§2b?ôr'`µ4%xUog0R2Lê"˜!R©15·˜ò‹Æ Ð` N‰¡ì˪9³G"pU÷Ò?yxŠ–ªs¬¹ÎõÿŒƒ¸˜1]Ÿú çzl–H]_3zÙR]CiNwšÐ×x“¡€˜*Œ¦É„!B‰1Ë£@!©ZŠÃÿ Ëc|u±úÖ³#Ü$C_s,áM…vòcÚþÈ4w¤¡aülá}±ÏsPöŠÖC¾ƒh`¼wÉЊ+†=ÑS‚Š¾öxEèùgèŽâ ¯ñbº_dfÂ#PÃFµG’È¡›1í¡B-@ÊÚþø-¿ýªú€µåŽÎÀ“ùßB±÷ñ¾€]SÛê¢øº¼”A3‚æ Î×½ˆûu ‰UºXU9v²·^Qc æcôèÁÕëW1E®8ŸÎ³ø¸ò/xÏWø¦‹v1ÏQcdìE·ª8kÃ.ìö:íwŠ?cĉýNé±£wõâI¹ë[7<|ó&Œ a þ„G‡’s«Þ×ÛŠ+ >qhEŠè®ël½ö¹(ŸÝÁKžA|RÞû·úRfáÕ‘¡ §ÐŽØ#7xÖÝœpi˜¹S.ððŠX8B”šç] œ`~¸¸¼úÇ7Ÿ7(A%8ªÓw(¸ˆïnñòÕw?}Û%þÚÃk¢F3¾>òZ[@üÁ{fãýøÝIcôf'°øòâ_oÂP ÎAƒ<¥9éê„wÀGmZX¯ß5à³F|]óȺî”]WX"xn»é½*Œ ®[ |sÁÔ@0¸Öám~&ÌSXémRWèµ’égÈßC°Aá ™Ñz(£À/Ø1Ø`6—9Ö¾±¨)-ß%~7«ôfåbOhç D+Ÿê溉¡­ÃÞ½×ôL ³Šôf g“òEì¹ç©ä°üÞqË“å~‘ô­2Ý$=Ý«rQƒñÚwëxu_îö%î¦*êÀÞ]–nK_€ 4ï½>—Ä4Õnƒkâ> G—Y9S§(±a࣠ûšµ¾T1©ØÊøaÓ®†4ð% ̪ù ˆ™7D!ˆlÌzËûM(RÅЮ—êëÔL -ªò#Í>Àžäýõ5^5@Ágýä9—‘/{qàºd<þèo BùõE Tej_ö?Ýú˜/\Œ‰µ+õr`µ¾dÝm¡SÔ¿õ&ûA}<>áø/œÀóûq2ª±°óirKtã¸}ö<÷´Ý èï1¦eü/AÛU‹½‚¶ÌüR]ª¸õÞû¾0MWe‰Ðåo»1FQnóÝ”xV6)!¼8ZÜÁÖF±NsÕ…üÇY1]±‡¹~T•ueëem4q~?rm^o³¾'G!†y5Ó+8´ÄL @áÑ„IX¶8Å3­†{JRè'Zb†Ë…tRY \ËÑEŒMßc3.()|Ó_̲¨U#‡ÝX#‡Ïnö¤á±íÌ7ý@ I‚øØ´)“‹˜/“sô}¦›­29|)‰¢^bæÑÒ9©Û·†C•sš4÷\®pÎÚêîÞ¶ çà­J´€øº5rnNæŸ'ÕÈE–«F¼ `a í‰9)þ¡ÆÕÆ!%iÌÓU‹ UÉáÞø×TÉù‹™ˆAÒóAUé\ýÇ6á¨Èžýg2„ÿ¡L÷¬RàšÔ`›8ábôFÍlu¬ l›*!Ƙ J:[-[…pn ˜ö×N$ê2w:á…]ÿ™‘_ØçIÕú»\3™áµ]X•åî«óóð#7 I·p(Éu~0êßÀ–â¼Xdåbu~(ÔÁàSSP•{fó2® ãÊEìðXÞŸiåyÚcÀ “€ìgB?Ý®Kë}RÃ(ÝaÀëîõgã‚Òmís[óAúŸÛŒâÊ%·Ã¨ª aZµÆTŽö=©nJVûõ­?]øiÛB)ye‰Ý•.(ú<Ë·u¦­ÏˉĚÀ6kØ“Xs²n¬ã<+Ȳ\°I¢ó›Ï«l“œoðâ+üŸÝ&ùmšÜi Wp¼$Ž¦ T(i –…ëªBAC`9sE )Ó?¸ÿÔÓ— endstream endobj 2311 0 obj << /Type /ObjStm /N 100 /First 1004 /Length 2753 /Filter /FlateDecode >> stream xÚ½[[o·~ׯàcÒÎ ÉáF_ Ô…–‹6uü ØBj$–\]€äß÷QGª¥³§ö® Ygö,9ûípµ†˜UIu¢VvÂBN ¢¥Prv‚BÅ5'$X)Nä@ÉœQ+0yTu–}"˜—Ôg¶@UúT ¤êw1Œü®áWÊ~×€€Z¿+…û]\æ∠,–ñ d•~7Zíw[”ú\ Bwq¤¿š†d*N• ¥àUx¶0.ª¨ßÃWµÉ^ÅDÙü+¥>±€²ìÃð&™0 ¤Åþ²’SÈ]pxLÈþPrõw’,!·Î"ÍVëøåP(ù]L+„!Õœho ƒñ•͹% E¸â«ÂKÈ×È—D ê@ð¼R +!¹„šr‚YÔåüUØ… ×\û] µt˜@]•KÁŒ†_ ÔAôg´ ë×.” ã` â+&•‚_1©´–NIPmÊA­#­%´ÔÅX«ëS¿«¡ õïZh¹8¾j¡Kx†¦Ð”‹Rh­ú ¼~3ëßAI=Ôʸº±^&æOƒž[‘>NƒU×< ¬¥þ3<¦”ºˆ€ËB>OIú«@ç Jêoßµ¾ö—qµOê¶ ®÷©¹ŽBK…?ØIWPªþáiYœäЄ´k«[ µ5˜ §.·¦ÒÉndÝ4ðêĹ/”†¸ôµG‚úçÐ8ï=|¸·zý秣°zt||r¾·:¸øå¼_?ÿpüÛÞêñÉéû£Ó7 þ ½]ýuõlõä õ‹½Õ«£wçá å "-)GWLj%&2×ÙõÀ¸Gááð:«ïO^Ÿ„ÕÓðÍf~89þKÔoÃwßíág>¹Yt…8²YÌ$Ûq´phŽ0ñ+ —նð`¼>ôü ‡–iB”’s„‡‹Ž-\7šB apk@Ä"ü^,¤æ¼¸¶©¥‘ùÀDÝÀH¸ÊšJy0-õ ¦Qyk]¤³ÊC(öó=—8øÅ~jÙ¬kïñv‚‹£bÃ!?µÊ=ÎŒîGX*=ñ â'œ¶¼Uó¨¨ÉŒn¥² ây«wXiZ÷ž Öë[ìägÊÏšé½™mƪÝ+ž‘û1¡ióªGnPS×ËK #áÛä+Ýh t]1|C»Ÿ[tÅt ¤hý¤¯ÛŸÿîÃùQ|ñÛɳÑø¿[Ê@RKlý@×.PÒœ[ _aS¼ÙGýø¥W÷S ŽÞ1rò@¿ Âß^<žÑ_À—~Îz\ñsäë¶íÌ}VªÒœÉjäâaÚ?Ū×ÌP1±ÈýyÏwàÁ?Vf¤»à˜Ùs(ä+¶‚•?ß d^Ï”£¹Šˆö+°ê{§žßqzëÒ^?>HsPÖìÛÇÈËÙOQCTÙ†d‘ðæešù”K ÛorÍdêœãBàÞ÷Ž_n©Dó›<·ø°Þçµ]{äÆ;î™î²Sy³í{cÛòúæ$ Ó¢·v”o4‘oìaÞض¼Ö’þÒ&rþ¬‰œ%}y¹ŽjÕ6:ª6:ª6º¥6ú°6fÙ˜e—³P·‚ÁƒÈƒ(ƒ¨ƒÐA >4øÐàCƒÉ C i0¤ÁÚ gœypæÁ™gœypæÁ™¯ ŽÁ©ÍÙDfƒ¨õ½uëpÐëW-­Û…ö¿¸â${nb“-äK3k÷j·Û6Pà†‹µ#–óœÍÛkílÿcï£&x‚ÞÈnùþ–Ç7hµöþ­»`és½[nÇá>÷Ùñœ=C?=¼€ü òv~üÚìõfnàï]|Ï…(ºµ Üì[.ä;[RƒÃïß?°Oº‰Ÿq÷t± Gq½(þ?Õ…r/ëágÊœkiÏ\WÈ• ׺„ÿg&( endstream endobj 2469 0 obj << /Length 2751 /Filter /FlateDecode >> stream xÚÕZYsÛÈ~ׯàKª¨*šGRzðzW.§6vb©*IÙ~IPB-.@J«üútOÏ€¤DÙ»•}üçp¯ç¬€‡2à,|ž“ÅL{ŸS: XȇŒ²æ8ÓÀÆHõŸ‰Á¨Ï3­Ãéó2ÓE]®·4|söƒíýÈH’÷8çSp æý³] 2ŒÃ†ñS¡‡®ââà`³“‡¾ +TÜ͘:öl«ö©,³ 趥ߘ5Ñ»|ž´èøNÂì„–fø(­ÅÄOok•0³59A%Åô‰T Ÿn £z£Æ:kj®›mä!_ÚšÚ³[ì8`J0Ñè„éªWƒ)`Ówyåf”083§`}GB,·åÚ¨×ÙO·g¿ž!oC<ÑA$':aĦɢ<ûü•M–ð V dOÍÈì D*&7gÿ ×7蜙0 ©8¤}×iC ­}‹à´Óç?h|¤¸ïo¬O qÞkÄíu±Ð)o00“0êpEW„5þŒ™0åKlI=…ðIª m "×z ê @ {ÓÁ)‡ˆír‹ÑÊ,‘Z<¯NôMà„Oð„:`¬¦sÒ~\CRGœáÑíº``(e f‰ ©:UÇ?ªÁëXTƒnêaæÜ­äV0B‚xt|ÓÇûšú L ­ì*MÖ®ëÊ9æĺl¤EQ/R4g”O(oºj²Ì"2£(%è†lú~Eß­ºJXœ05K²^3ÅP}žãÁW4ãå…pSu‘ïæß;&-Ài|‡c®hSN$&À«@{¼èNVõdh¿¯·…åGVµÛ†üëL0ˆ8î{X Ëz–Œ¦sÚi‡iŸ *Ð]dÏ-nèГó.Èw:?@§:¯6íïÓ¦¥mMéðVÚî¼Ø·'a‰äµÀg襈à³î{EFÔºÆõHÆ‘®×EÇtyé@Å`#fw°i?²ÃyzWWNfXÙmµ-øÖ~Ÿ«'à‹q*-ä*ßÖŶ¬Fx±ÀXÿÐh9©ŽÐø©F ñ#Db=“D@"/}âaÐ<¥TKÚP ]yõ…1Q囌úZmcªº)[ôRù‚/Ýá¥;<ïoáO‘à~̺ùžä¢#\¹ÉËm±I«¬Þš°œ¸#Á îj°$ôºb'œrê‡=`¼ÎhHÇ;cy‡M¤¿£JŒÁQÿ#“yt`²éÙŽùøÅ·;n[×{‚2/`~|œùy‘"àµqž2 QZø:?‡øˆ±ûʺɨ·nHV0ˆØݦÀñÛâJ_,Þº–T&¤ÏøÖñÚ„ã`â·)æob±¢o®Ñ1Í|³ÝÔ€L¬W €÷u¾°þ¢^ ¥ô¿êIä€ê*ÛwEã0ùP `Zô3̳U väe®cÕ«8Ð~âjTÑñÉL½#£óôŽ¼#{þ48ü:]ü’Þe{µ•Cù·%£Gÿ§¬H;Y V.jxDzðˆBóïQ®è¤>[’“ñ+Ë Ò0µ·'ùv°~!€ ¥‡ ,Óæ—1FI@2îI][à+AÉÇ4ôŠQ„ؘˆvì÷qì7ðC˜R å$v°òi°j“¥KÛgð;<çö“á¯Ñ{„L⯬#ÂÆH82qá`¦c€y“¹Y˜á`˼¥Ñ £äÐ=·Iv-rȉ »«ÀÔΗã ^½¾<âùGrÓ‹Ûmçó^v)0tcüXô ?þ/æßRtàqòWvT»{ ,ÉŠ€‡ºÉG9ùš ¶IÎ¥æ]rnº[zúIËÑÏ%ÀGËðµÉ9nÊéaŠ˜@¦KÎe¤;7Š€Ô(¶Œ?´ô"fphÚn"³O÷Ù11M# ¦)’›—Ùsç4é¤_) ØNól‘ˆ±®Õ§KØõ(⃩v ›Ú¯,è´{ ;¡\ÅHñ®°ÑV°»uŸé™Y FfÀ/¼bøð_÷‹‡G“¸6ö·Y‘—yå؈@Nè $û¿é~—1–Gâu饈ð7ÉK8÷l¢gK:Œ0?r‰ ùç¾@“ÓÊwW|ˆvpjÅ2Àài0QxÐT÷1¢çï s 1ÑÈuv7™¹ê1ùÐëÍþõ[[}㯠õ7üÊP.Éÿ>24$@ƒ0q”Ë8ˆ£Ä£Ä¬ãÞ”ŸnÏþ ¦ÐUË endstream endobj 2495 0 obj << /Length 3359 /Filter /FlateDecode >> stream xÚÅÉ’ÛÆõ>_ÁÜÈŠÙîè”í*9‰l¹Å‘¦r‘|IŒˆˆh€Ôhòõy¯ b¸ENÒ4×o_I'&tòÃ}æï÷÷w_¿Ôt’£µœÜ?L˜LKØD§Š0Á&÷«É»é/³”N«¦)›|6çŠN?eu‘ÁSóuV×3¦¦ÙSãÞåLÂûjó)_Í~½ÿéë—ÂôásAp»…ü'<èPÂàŸšÔˆWxxó`'ûØ)¾}ýæÇ·þóqê¤ÍO‰J,1\?OÛæ7#¸«„P͆¨‡»ëߥ9‘)÷W)÷Å7¦ê#eHÂÓ’Ž\ªI*Íø“ws¥ôôeñ%ì¶è—‡í"¯Ýºzp›ýŒMó]ïû¼ÎöÅŒ«é' Ám×ù{Jy™oórOfsÁèôuàT»]Q~pOË!UéÁyð‡&_‘ѹ2‘ñÀɱöô(Iá¾3QÉS’0$U<¾ú»ßGË>ÛÃY–´bÀ52ÿ6{+ƒþÖ…¸=b|ú"À"À§ž,4Eð,…œî×y?Tµœ!â“„ÈDO(1Ê8Šö9(‰å.öò­œ-[¼ÀÊÓ釼\æ±´WUéw2ÿ}ž-×A]ò]¬r€Íźç¡n>T@äzKFmýÈÆS¢ElvɲÃfß3îéJp }Û¶jïUô=U´¬.ÆŽ³‹põwFȾÉ7Ù>˜ò.s¾u›ï‘ÿÀÐÌJ¸b_¡þùõýÏH+–‚ç(IQ\ÄŽõU¹¬¶;àÕ¢Øû§1*Ibz¡`ž¤é´x¸Žfˆì ÷UK;"âXâ’µ~Ëf ceÝT›ÃÞÚî|DÆç;Ði@Ý‹f_‹?r²—Øch4ø÷jüEB8MŽüvÀ‚묶!x24%\,>ß̥ۢ"ÓÕ¡vŽÖöûålïßöb.E2mIÅ3W“*!§àæÙø=ðÜœÅÚÓß©>aºesH!ý[0÷b‡ñwêâÃzï–ë¬\¹US¬ò¦G8¦òZÁ1Â;£çâP„ÊÄ‹#u‚CÝ×yç2¿I/ò~4¶À7ù6«?Žù @]$}ËšCÐÝ£7KÖ—ÃêZK2K.ãI$ìX™Ç2%àUy,@K¢i á+G’Žè@ààOà>Lê<²á€þÈU ‘»#Á¶Av²Ú¾RÓ]^ƒqo1º[Ãf&!à5cÃ~„pYP噜f%B~r.ÈãÊåòù/­3ÌýˈÏh$Cx\ 2$Æ0•¡|z¿v‰Š„ô-+íRx¥³X®ý•£É‘ðÇ‚Él|±ÐcĪ÷©§ Ì·—q*œÙQá3XtÞß¾.AnZ#uLÃÍEîr`|¿ÝÕ^ð©ÍÁañ±_,ä{”:—˜Vº¿kë@`±ÈóÒ­šueøÇw^NèȬ(qaÅ8ål(Ã_ñ›Ö?ÀרjnU•›'·Ú;býCø»®Q‘,ޤ˂ºÇ† “¡!Ø›NJð´ÌÊ1ùW{¤ZPj!(¿ÿ¡,*|²GŒñåPˆ ¦âÛÊ¿~pß:½¤'c{ÊÙN6+·[Vû—7ãΣߩsH˜€Ô•ÛÎÔä>‘ú';|–:ç>íö™ü\têÒ«ƒœÇ6ËnXi‚ÚT×ÿmÜ_G)óeÞ4YýäöñR c$ÿe²…ç¯ÈëÚ&x²Ì6O… 'ªOA|ª}]Äá¸Óf[.KÛ¿u°¯\Þåp÷”-òF"ôÀÛf¶q sLJÒoXÚÅhÕ€ïŽ :{Âw½:ž|g‹Kq›0›Ò7fpÚ/ÊÂ00‹¶ˆ ÁÏ+>ýÑyš¼ï…Án°2UhŠh3–±<„&jP‘Zîið]Ùòc›ÏÚ«K>±‰°M4Ô9àòwÊEL’h“• ÜctHÇ2K)LwÇã똆Ð\w¿äºu†F«+:8p\aY…µ²Ñ€g±)p ¢à“{o“\4ûb³qË:ßê2÷ì+<¤7¯^¿üû¨‰Wzü¼ôEƒÒŠšAÑÐ}’úìÙ•¿Í._ö\k¤z^çê:P·=XGÉ™ó‰Üz˜bi‘ä,8">n=½ºË£JœºKµm)BÃU€•Ï&ÐCÀšhÓz(Ÿ , HòŽ¥®C;l~ŒÝŒÒ=‡Š–½Š ñÚUMQæ™?Ú<ì·~]mÚºŸ{ÎHöå2’¤-Ê/>µ—R"ºÌñÛ(xSÝz™Åg@`ëÒŽa`†E dº/<,ÚóX)¡TOI©?t?N‘T$´;5FZJ˜>EŽ¾’St¡{Jo›B×5KAg’ã¾ 9«ÄPˆ(úòÇ3oÏbÞ}ÙÛâÁô4L*ÑÃÎÆeÓ¥‚³m£K"…O«~Yc4i&2´L” ‚Ò9dK!z´Qy]µÑ£ôg|_#oÏG_´à½6"s-¿(Eü=ýnüÜÌþxVï>?‹Þ ³úÉ\ñnJ¨Ï£ÃðÏ;,µ0ÚIš.h;Ïè48ºfP!±¸x†£›¡>@Ðïùà€…Ïóžú¹Â./›^¤=¿ -lÖÒdðÙq¤Þ6¶pÄøЫC¶qÏÒ‚©Jˆò…K±ä úÇWý·å§šúqœ»Ügj2ðDN·hU˜Ä€Ù2›_õ§`c¼¦²¿MᦀC!^Géÿè¢5Ýþn¨?PZ[6ŒÎ®ÿ9c rq«äÎ ˆæC^·rßLÆ)‘/ÇCYÞbâ%çÆ_fÆô{ ×OÙÈ5CôFÏ’²æ™Pv\<ÍÝÓúTÀ´+bP„‚&×ãê‹Ì’¹QG³dØÔÝØò˜syNq’óì‡AÕ€½–ÀŽ•*b¥‹l-£ÜxOJBS÷û_ª¼“h–Ùƺ@aÚ2`O †À/‰2¦¦¯v KÝ(÷ÅhØtý‡Ž«`†TbÀÕÓ"ÙP:E‘¤k-.F€ÛÖ‹EÃB“BÁÛs$š»¿Þßýv‡ºƒ?Ò?GÀïM¸‘“åöîݯt²‚W?´„I'öàv" 5Úìfòöîî'ÿ>#”]Çá †ÑKÉJbëƒI€;é¤wèãˆ4e?öi^‡ñÀá GÚNUk#¨Öè`©ÆÁ¾”ºR¤ƒRùôÒ.}Åèž‚—cTÅÒçÜ\ÒõýÛbp0”†Á©‘ãn€d®]åÃ!êC"Á¡hI}oZ™èÐÖÿÇÍ<¤ endstream endobj 2437 0 obj << /Type /ObjStm /N 100 /First 1011 /Length 2939 /Filter /FlateDecode >> stream xÚ½[]o9}ϯð#¼¸l__DÑH ˆ‰aaµ; ¶_“É!S2€ç¸úµ˜¬±I®&§B|É™\Úw`¹o¤`Š«íW1%Ꟁ%â»IMѦI˜@I\m”&O`%C‰öW2á Œ¤”ÀåH0¾Ò„ÔhªómŠdª´)°î56EÂzª6YLÍ«_ñÆê]|U­MÍæç|³Éœ1 ‰’ †4 +†ÚŒ§ÐÌS¦øâiñžŸ ÌÞUåT–ŽÛ”[`êð„v¶îE‰?yøB»‹Ùà ü&Xƒ÷9Q¿³ùÒUÌ\CVéU¾¹ ÞõA\{šuz—oaaA›3×Ê!> ä)ÈÎÞÞÎðêÏÏ33<8=/w†ýóß–íúÙñéÇáÇùâh¶xÍ°àÞO†§ÃÃ×¾]ì /g‡KóZR°Bµ¨MðEø„¥î´â:ã±foÏ ûføiþjn†GæÞ‹ÙâÓÓÓûæ‡vðçîBŠ¶Ò+Äfú± –N’q©a¾V[¦m3§6@õ«M¯ÅðäÝ|¾Ät3[ïfqY®X† D «´1_-íE#€%¹Èá10|žœÌv]Q'¥ØL„h <Ñ×lT’Mõ•x7¦N`‘1Ó½·Âµ‚Õøz³JÎ?œï:?¦•Ët€0ok`zK–έ–Óm*ñ#ªÄ;Ë ¯ž3#þo‘¾ÿÔ¬7«äãÁÇóÝZÆÓ RºMH7üW`¸HÖ!! YZDÜk¡<}øüÕ³7÷BysÄ ‚oOpYdrÛBr–åªij8µŒà‚pFëâ¬Âj$# F¿ ˆŽªà¨È´¢ §ˆiÀQ#q(*O†C` ƒB!Ìc~„6«„4ÑM8|U!PD©«ü‚òe¥eÍ%·‹L·.€áXàfÄWfsà@E‚õ)¶–é–…éuU^ÂaQÅ"¨–ªÊ$i¬Â†\¿b(P Ëê žŸ-¿,öÜ#†v” …ÔC¨TWŒ¹øÖëõIæùˆÓc1È—.fÈt¨·7ξü×ld%F¬°F*ÓF…"N¡Æ®¶A7(!•´ˆ׃øó-sÄåˆ Ë¡Í „„®ÝÃ>ˆ} }ú ÷A—»dí’µKÖ.Y»dí’µKÖ.Y»dí’µKN]rê’S—œºäÔ%§•ä·#E­–ÀªIðAÏ ñܹÓF~szcÔZ‡,³æËD§¤ˆ ÙÀVß ôHB™0æh3Ü[@Ta+âÓàu)â:\¯“‡¿<Ûø`Ä”†9©Š…–²»ÂË_þyGW; âŲ?šZùØXgÁ5XšßÐJ8:ÿ8ß­õ`D(¹„l EHˆdK(nÄö œÖ²¹N$[O¾ŽÏ‹]§#ú Š^n.(LU+|E˜K+8BœÆFälJ—0 öc³v„»Ûè7n¨ºð ›@…E;‘)Ø|CÈØÿõçC°À15zÛö± Š=âÁå ­Ð±u€,“\Cˆ¨ªJ–în ßøg ¨¡E스ʂܷ ÙD7ô¦çÇí7ª‡"r&îÇ1{ä¶WGp;–ƒOG‹ó]WÆo¹÷|rï&åõ[½›”{7)÷nRéݤÒ%—.¹tÉ¥K.]ré’K—\ºäÒ%×.¹vÉ5ŒÚŒºè»¶>a^%È8­ÒõûôÏ_>Ù?ß)|8ÃC"˯&Á„óõi÷"¸›uá0•'I"O>Â)Aj ®«N—d¢eâñš Q“eûy ãÆvv)Åñ˜Â@´mwÔËšÿNa”…‡ü:–\7!ø>•*ž¢ÑHZ ÛÈ–Ql_¥N‡CB°lðk …!U( þ±O«ùút{pò~~øîn-ãoN;¡êpTuµ5xw–Ô—[Èþâèh·Ô1}ù>’u}•"áÍ„%jʈ]˜˜‡yÞ#TâÍÝÜŸÐR¥²)MÀ2xF9‚ý¯JU\ç)°&F Xn !¶ÚàšÁu*ª“*ðkb0ðã9/¿©÷áõû4a01ꥯMA1¦[ S ãwËQR¤n2”ɪu)q¡£@Ži‡|7¡¸R¬§1;ÉÚεõŷâ:‘¿  *7v¹úa{RëOùð8ù߇ɭÏØd[Zº…úÂŽ®Ÿ°þ¹HúHOú[7¦¯û0*°Ö²n${ø¬su2oY¯L`Êðø5ÿ‡Ò@nó¹šøO¬qKj{ùÁN(¹_@¶¶|Ú…¶U´ÝÓdñºµl¤õñÒù‹ÿÀdûZ endstream endobj 2533 0 obj << /Length 3079 /Filter /FlateDecode >> stream xÚÕZK“Û¸¾ï¯˜£¦j ’©rªœMfËÉúQöä²÷@IЈYŠTHÊ“Ù_Ÿn4>ÄÑË»‡\$Ä£Ñèþúð›Ç~óÓ|ôÿ—‡^݇ò&a©RáÍÃúFDŠºQIÄD nV7_f_¥T·¿<üÝ{u¤½A) ULç·ëÛy ÒÙÛß?üü•G\ø8þÕ}Ä{Ã"ΔHݸ×Ôc0±à,Œ}q3§é¬ÝèJ1Ÿå%­•­Vy›W¶ÖVôúÙÏ‹êVD³oø£é[ÓfmÞ´ù²±]Š¦²%;·†¯Û¬µS¬«z4©®kÓE h¿™+ÁxšÜÌì4J‰hÓ_FbÖTÅžhÄZnÿ?½}ÿá'dSŠ\º£Ö¬\QaY•ngX-÷Û…®ª’°à—(òRg¶±ynZ½}i1ÁÍ™øÅ|>$¼×Y¸Î|–ÕÚ ðTëv_—zň "a*€¿¥a؉„äb¶Ó5½ÍÊ¥¦†¼¡ÿe ›\fn_ˆÑ1}šMµ/VT^Øñn©€GŽÿœÁøU»9smªçqêN@&˜Cllþ?{½BÒ%·²‰_7~P^Ø)hP0›€i6Ó&&f:Ô$)c%Ñ1UŠ™PI_“,µ´„f,feV<7†;Psÿ¤;õ3Õ–UÓÏtÞ2YCþ µíóùZ<“˜4ùc™å\.³²uÛÊÉ“Ò”ÛMVº’ý ÚãÔ«»MÖØbÞ6ºX#cm{€g@.Kè¤D° ¬]q0a @ Ô4ºÌɸf7pFÖ{‡æÄBu¾@Û£¦’¾ Á‚8ú]©óÍ““[LX(:$wò.°þg,h—±‹Žã¾»„5³OøßÕ”ÈW Å¸±ì‚ûhçºâübɤ ¿fýùÅj¼39û¼Üìmy]öx”bJ©?èxÒ‰Dr”ÞñãÔDÔÊ!÷âË»„“O ¼óšân¨ŽCºAßIó"N¸-ça=ØiEC¬ÿ¤‹n¹]Fq"HØ™)—¢¸|gžOÄ@®ŒB’. ¹hÍ…É9B}Š}Báÿ¶YýëŸÄ›¾TKƒœp b–JßóÝ?ß}ü<5ß  Ñ¥^b´Â5ÕVS)™nÓ¸Ðí“ÆTVÀl몠 8¶ˆ2Bf¢–þOºo¤ªq !ÃH×UQTh%ŸŒl†2Õû •‰‰±Éû*„Õø œbL)áWX@1£`¨„zG%»'¡šÝç5%`p†mÂ!›¬±KR'KHõD‚lWçÂ|ARBç2C³_›Š…±—j“Ó¥õ[,³|M-“) :%Å¥âDvZuY˜€&¦ä¬D.´ôÂô$ð¸Eߌ ­€@SB ò)¢èDQ{·c#mF¤‚ a\ŽÐÿ&-æ¿y(­ÍG®yØÄ}ÙN˜œ E0û¬17íºNλqc2[Ï)€r'ò*ùðj@Æ—ÃÞÜ\`|˜¦Ç}¿ =\•¡¸âPdØwª.8 p¨¸ìŸ†Y߃aH Ãƈþ.V*pÌyª®@óI›Kú7ixòo¡:3û–’f6k°(CÙígD]"´ËôŒò…ÐÁIAžö-NmÊëºÚbIYšº„*ÖLBõîÒhoX»3u7”2<ŹH²¤ó7U±²dxê¼îÕÕú2Òâ8tÃ;-82òT™dÌ¥`1O‡g¤×HòZPÔ¸p"5wèÚAñ}Õjj4³_Æq±´ÃqÏñs±¸ÓòkìkÜÅÝAg°StOð ÝÖ'íhü¾Ñý™“Ùçeöó›·©œ½Á{ÜÿaYŸè^ ø4‚ì#íbpdykÍÂɈ¸ü~,þ#ïÇþo.ÃFù¦¹Š à-õZNe—æÇî»LÔ|úvb|ottN¼Ù³¥ÉÍήG¬·2 %+Ã.×l^áØ,ó2kÜ­Š‘ïNAmϪ””Ò=¼•£ƒ»UtŠÃvŒ¥Z¶Ðý–ÑzˆÞåšþ y¡@ÁnŒSššìÍ°W“ÿ¦ONÞeØq}b 6ãÖ‹¬±(-ŠŠ!Ò‘õD?ˆ2õèÓJûjŒžå`½Û•^ÙØZs½ Lë%³G]ÛÑz7&íû±ÀDÓ(;¥qÎcLä¢A':äÆ&A…šŸò¢ ÒBOåXö^›íS0>8 /QyË>8Çþî £Õ V¸G7u5!™{ßS>:u~÷ñí`ë­@„˜<º”>™>®_KÒ†ˆ¨S=ñ§ú„Ìb3)ŸrœQž3Ês†BÔ‰#ÃNŽiÊÚ(,ìLxZäAƒ7ÏÞ–n%UeTøEiÅ€OJ—ó—Ò>¤FC5´—±ª¥“—±¿2O¥½ô€Žx—³¤çVÐÚ—eZÃ<¿‚~c;íH(©ÔG.è]iD”«(³åe׆‰ÄMJ÷HÇ>г/u"ûRÇ^ªÛ—/¨¢ü 牟j½ì½ñ´ý¦Z;Ézðv†]l(ŒýÃÒB/3c÷Ý€ Õ›T—ã˜Ð•>úöî™Wßrߥôï.Äùw//—ëðíÇã5gâyÆEÓîi 4HE©$“7ÜäؾÿQ|0äo?ü×í endstream endobj 2570 0 obj << /Length 2936 /Filter /FlateDecode >> stream xÚÕÛRÛHö¯ÐËVÉUqG}Ñm¶ŠI&ÙÌ`ÙTmf„,@…,y$Â|ýžÓ§[–d©Ý»ï}î·–ç\;žóñÀÛòÿÓÅÁÛçD,å\\9\…Œ‡Ü "ŸqÉ‹™óÕ=ËæI}ÛLþ¸øåí÷–KÎd(á,½îï“iÈ…{ZWiÖ4yy=™*Ÿ»íM† Ï­«ª¥¡&ûs™•mžÅüîùÞ§wÇGØà~9Ýçó>x‘ÇâØ·þcHœ3ÁíOŸ£/H“’—ý/›ìjYPû~ÂÝ›¬À«WÔÔÊ5òÎTÉü0r¦àðcº$/۬Κ6›M¦" OÿúxçeV®Ô©®è¿ÕWR{ž´uþ ¯8øùâàÏ„ßs¸ÃcÅ$N „ÊIç_ÿðœLþâxLÆ‘s¯—ÎH± ˆ Y8çÿ"Îè""Î)á,:»É2}3œÃàbæ;5J‡íœ}„“Ô@FBæE‘%ñ§ã'šgÂò¬¯ÊgAܱ&)gO¼¶÷/ý¸ç­S<¶qõ›ÉTz¡[ÕĦ{ÍøàAŒ×“î¨È,+X0”€¶">β6K[j—Ë¢ Ö"Ÿß½›`~ÛÐØ~„w¾N}ÏsÏ—— œ›W%möY<ÀØàÅ4€€&XíMµ¼¾œ…r; |Œ’éñ´*Ûº*êi:H!Ýì !ÿÝóDšge:á¾û@KPŠq…YªÜ+M¨´­êü¯„@Åy䲞oªâ÷›“7I“5È %ÜE-V6Ã"Ñ£¯æBUßu24\dõUUϵÚ!ñ—µ69ØNʤxhìB „Ö¹;T-Väœ/óK£Mfì°Uõƒ9£²ge›îÒˆ1²KJôäp*8‹y„6„) ’ãÎâ©•ÅŠoÈ"Zñ]ñiP"“ëÎà¤upØÞh9تLŽ%œ¥nG½f‘¤ÙKŠ=„® i4R6XéëÀÁfÅ1@ÀB?"¼O‘ª¨£iÚ÷?RK!Š’Åîòa„ýMÕ±»joÖeg c{Bdæ7ˆ|'Íž¸üS®XˆCˆÅûì*YÄ»¤XnB¬šðâÂ[—û›<5È¥U îiQ•³f(ÂÆ#Ùm OgRvba€!,|3+ [$5ê~2ûX#Õ6Å¡Ç„ßCéIÎÁg|š7Ò*!×¼Ã.\BŸùBŽqÙ;þñ•t¿h‡"ƒÀmòë2×æ] …`ÿ€ßÚ:¡8YÓ¼¤Y6N“¥`l£ã\¹œguž& ¼ /ÚR|hîiiÆe,Œ35`lì<1Šr“‹G ˜VÌplÀü)·Ø0?švÃqed{Ù騵Pé$µ´¢¯ÝEÝ€bmÇœŠà"ƒm³§ó‚–Y† (3 ;œEªÔjV]?ÐȆ ƒ5³Vå—È€¥–tÌËŲ¥¦ êtAªÊbxVè&`¦æ—…ÝL;€‘~ícx§™×í°`bk¸°K<Uc¼‡ ^ùÖgÖÓIºAP¼g]›Íëk¶Èx‘ôÐD:Z á›?È´pt?a߆! zñ:)ò¿,Áªr+Áö!7{g ÆwËÅ8žä;•±Ÿ°¬®P‹îòêÎÑ"˜íY¦í²6]õç­þà [y« `(±ÿFTÞ[1b߇˜«ÓúÏ¿}>=ß$À1óTkÕW6ætºvž,6F ôXá( €—ÛÈD l5‰«é’Z=vZ `#GbgÍôà hZUÏÈðã)ÕÚi»îA7ÄÙ…¹=÷³+øy1ùÜÃni5ä:^ìI©Ø%¥ª“Rl ¥TY)ÄFOJ±‹R:˜·'û‰èzNCaÆк«È•hżÐ=œWº$­´&ÏW®çD‘ ºK¤Ï»¢¶%þ פْjÄú³/mQ°”\ÑÿãÖiÀ•{Ò;ƒ7Þ"ã³EK'“!Àzu’ÞR²6pP`_ò˼ÈÛ³ˆHÖ¸Á¹Ï²àÓS>[и·U¤")‡Î¿Y.`Oc´4o‡Ùš)\-M‡þ¬Èöª­¥ñ¶| ä- Võ¯9èk6®§7ËÚ;æ‹"›wYd_«¿Ó"rõì4 ‚Gø£ÜùÑö€9]<|>Ü%=ÎBE'yÜ؇ówÿüíì±ÇXÜ!÷æiÈI‡±?út~ñïóu%8…ˆû/`(8„§#ˆÅÚ@ñøôìäË«^%VW½;9ú1X}þéèäݯÝ%AÂçÞ…æž ¡†–þøu/ULEO] ÙrÕPÇ•›*ÀlBŒ6öù* ÀÙ(E'y–˜Ÿ–âÇ! zMôâˆEÑK ‡&ÌGèïﱯ žöv³`¥[0E[ö"x†ùÅC4ŽÞ?)ÌÂg!s|?®€H1M»öì4P¯ËÓ1H8®vÆC6 êV6ÛRíã{Vû°danSÊÜ`™ U¯Œ‡+ïs]”PôÒŠ# ³½Ÿvá4Æ98QSM¡éÕYl5°WgÁ:ÝUk‹:8û„”™ÇÊFSs÷¤¤F_‚“t ]fœ›Ñnzbá}j‹ç¯–P¥§éÉÇôSóàüœD¿<Ðberi].Æ ëiš7®«l “x²tŽû°TÅß¡{<0úûºˆ˜I¿«Îêä#4”ÅFò€-ŸjÄý)+èÐì²DÙÀv ˆ‰Ë•þ\‡:­&O£§ð Lâ»3ppù$UbÒ“ßIRÊqðyüíŠÍŠÜ¦ö¥¼œå©M¶ºï–6$]Dûq!Nz`åÔÆÂle6Ê]öÅ÷:&c³oÍ°ß½±š‘qÁÑK³qe\°·þ^›ÐÀÐÁÅr^6lEܾñÁtïj}‹…>ȃƒöŽËùóóŽH©yGÌBñØ b÷ô°<~FX.Î] ˆ„»Â ü~<¥€|ÇxŽãòq}(b¡êò†¼Ü£tJwñc¥;Ð:Šôp™ùü³+¦Å^éa@hâÉ!¨1€ŠóéT„݇Ô!†|ÍÔO‚aqèú_X(ñ endstream endobj 2617 0 obj << /Length 3138 /Filter /FlateDecode >> stream xÚå[ISäF¾÷¯¨cÓ¤sS¦4L„ÝÓ¶±išlG¸íƒ( PŒJ*Kª¦ñ¯Ÿ÷rц¨0>Ì”•Ê|K¾ïm‚ÎnftöÝê®ß\¾ùê[ÍB)%g—×3¦R6Sa@˜`³Ëdöiq~_gõÁ¡`z¾ºëô-Ü 1onS;¸®ÓÊÞ-×uƒwj^§jgeE“°`~c'«ùçÌã*‹¯òôà÷Ë€2Jü³ Iôçß¡’ö $‰L1^ÿúÞ¼ÿþòÍo¾9c3r¢ÃÈ0#Äl±|óéw:Kà·`U…³;3s9ãDEp“Ï.ÞüÇJe°™€¤Ž†R¹x÷ýOçŽh+Α,yD´=‰M9ˆ'ûÓ‰¥¼Éébq»®péÙ!—‘LÍ%QÙµ–qSe_@¾ûqÓ^‚ÐÁ3ö’-[Û÷‚ù÷ó—`)F‡q^—öîÊ©9I£”ib£MÒës×yÓ×|¾¶j¦€RÎ]–ç0= óN^u—Õ©}¼r×UUâyúœ%iÛ°ö%àðKš¥~>`Œ¹ Í«EÙØ›ôuìv1fWöÖ^¹Û¼²Wa/qåvoª4n —8êÖ¥d ÃN–ª/z:¤îßéµ ¬ð©ÄEFò—! T{âÿ‰0ÛÙwPÆ‹r¹ÊÓÆgå½hÊ*û3n²²@ùìBÚ¡Ûg@àq«Ã:WYž5÷Ô’èÎÙuà ¿‹âµ¸Eà¡Ç,ÅË´hì³qŸ0%¶«¸j2Ô ><àÇN5~¡¿üM^^ùw,4Ù{”Ð]ÖÜÚ⨜¶v;©CÐyP5¯²âÆ \Û«ÙHj=Â.ó[ÿ8ÚIW÷£·0@MÀ €ÚvüºÌóW¼ëv\!›µý¶72ºÆÀi·æÿá§gª E; ¯‘œ, !k£@ag#4sge ”y"]†HP7c}Á—l¹^ºéU\ÔŸQ iUÇ9p,)‰Eœ‹î)ß ›!ãv¦}µr‚GÃÍL«ª´þž)î"/c†…³GÐfœçiî‡í¤§çyšwfË"ñ2ŨŽd=!pM){–º*€è-Ê¿;½<Á£«5ßÇÌX$àbÌÊ2®þ[OŸ¡ûæË„¤óc<ô‚ºc*¨1 gð„BÇëMO…Bš÷Œ¤À(ìÀù¡13ß“]ŒÛ™0Nd•Vͽ}ªoËužØûÛ2OöÔø ähwFCKÔÙûócB¦"Ây8 „€ˆ!|FLÈ4#³+©ÈÆñé&©yZy¡í¯-N¢0Øõrœ©`CPa倿í1ï C3<ö| 1íÉ3h´]n£p!—j“šÃý«¶älT‚Tù ˆUP båÏ’ë?2-]û8);b{F¢""”nËT#4ö"\G!á íÍu˳‹3¹ÖÄD ´Àeb§%F`š3ÀœW(0™²C>ݯ¥½ÞÆ&¶ÎGb{Y€ï†0›'vÌ9^ós/vÂgëà=FvN¾^bxþët[ aì]/ÖWuºpñ–sHî!ÈÉÚ3~b¸ÆN4±\We]û`B"Œ‹Æ‡*&€i%Ö,qÜ”ຮÝ[±[ ´Å:+û¼ˆýj_k›òÙ*»BÑ®ÑwOÄ mŒâÐà p¹8—òïbÑVçÉZ¬8â.ªu„ 'X@‹qÆÒy°±´‚¼¤ÎnL.fÞ,ÝE~ïï\8È8˜  Ê0&®ÊEZ×Þ²÷ XvÐáÙTî †3(S0É:Ȧ|¿í°Êí^ìvä’¿6‘„µùÀµãü(»IÑ`¤kN½®Ç*Üê\m‚ã2+|jK*>Á†;9'iáÓ]/þ, N;ÿeÊ2ý5ªìæ¶9¼mƒà2‘z§¤µ 0”ƒèÅF-XÅœ`ˆc°!G‰h¼ÀƒâÃdD e·eíxKÖ6€ü\—¹‡@eãÎd7Â-1ƒ0÷ì áxÜÑRANíµ¯âÊð÷‹2@h†@÷3ìoab&a……òA`LÙüüû‹}‹-0Ì[C?…6žL¾î©u¸ëv:yµŽýN·-)'!ظg„òn[R0$iW¡SõÅÙ×çïÿ²Ù€Áiþ” ’«—àO)˜zUþÀ³0ÈAFu·iMútE"üA¢öütW’ÜéÙåÆð‹… ”«áöË.!p ;ÏðëD®ЧÁU=Ÿ=ÎÀ i5do‹ÂæL ãË­ÐBì 7B_[NœJùM¨zP¥p1ÝaÀ»ª°S\­q4óÓa¸‹PáÀ …%@ îRû`‚˜„ñ0>;‡CÞý™i…s‹Â"Mµ^4ëÊÍÅXâ–ÂMߌ9v½4FÐR;£1dvœ÷SÖBöC™©|@¨šsDípp9"FÂ]× aeo¤ ĦڠD¬!¢ ÚÙÿš*Z@NוÁXÇÃÔ—­òÎ0ðÃ1¶9iØçºÏ€pøz]˜3ig¦ ¿V¾_Š3WiôâÏýF¯yB+J€¯éumñ•îW|íø‹1¶Lú}gCZÛiv£à3GqÖÓi´³§Ð>ø:e±®¿r‡²IVc,q@i¿¤rèƒ~Aaºý<Œz@Ž€(ruEs‹ÔŽ­Æä ®tͣЃU„aþùŽ£JìÂiž-³Â}Ï3Zý×f0ëá·H÷R¢|Ïš}¯¡˜?.)Áõz’³Õ±[¢ß*뉭|.tçk4X„°ÊäEƒ·¶/nM{ ͪf•#Y±Z»1üÆb‰‰·[l‡tõ“Y¦Ÿ â‹“ ª™¹O!é±> stream xÚ½[Ûn¹}×WðÑûÂ!«Š·ÀX`-ÃD– ÉA²±ý •k!ŽdŒ¤`³_ŸSœ©‘f#µ&5/»‡]<]¬ëiš¤± Ž“‹­a¢K‰t@.Wý)°«±ê@\K¬ƒäb¨ýVv‘HtT\äåƒÕE©a£æbŽ÷bp±ô_ct±ög#.C6Bh̺VÄ%µ¤#ü#Üï©€ÜïG%ô{P9cЭDÜ£à8FÑ1Ö9æ¢ïEìx) KrîX(9.µ?‘·Ž…Š“б°8‰ k0Vââ ' *3–&¼é=. £!…’ñkJ]m¤¿brZ ° g—¸¿¤'YJ©.eÕMb#Õn1Ø–HMú\¬Æ¡K€ú"Ùïb5æ${OŸîÍ^\œ_¹§OÝìöEAw„ ˜ÀK—%Ñ~z¤¬/ðL±iI±¬.Ôæ ›‚±iâÔ#Vë¨û…uZZ]`Á˜W«þøãÞìÝââôx~å>¸Ù»ç/Üìýü·+÷i?ék¼ÿ÷·9~8ùu¾7ÛÇ+Íϯ.Õ{:‚½ÙÑüòâzq:¿\zh¿÷fþùìäÙÅoîCÀ ] †ü ,ð4Ì.¥åÄŸÎÏ/ íÃ20*žW¶Ø Ù Û Ø Ú ­1ØÀ$G“Mr4ÉÑ$G“Mr4ÉÑ$“I&“L&™L2™d2Éd’i)ù îªØ›_ÿrÕ¯ÎÎÿ±7{v±ø<_t5†O³W³×³ý±_¨æO±gˆµ¾À¸r [æÊÞ«JÇ_UúOÝÝìåÅû 7{îžÿüæÝøï\^rk}!ñªY„MŸ‹ë䆫ª´;œž]Íýçëo‹?…ôÿ ÙÔR’oJp^¬ ­Õ7xd¸¾ÈëýÃ÷Ÿä?Œƒ!){lÆ,ÛgxËÃ0ÊHC>Â.¤%Oð ®Á Näá©»ÃAä3¶¤àÑ%À^äàEø1ìss}|§n^ðú1Oé‚Û’éñ×ç¨þ×85¯ÅÅ€Õ>¤‘û`z êyÕ¨×ü"\="íŒX‡ÚCn¾Â= ²—¯p-€”ÇÐG,^4m›>¨øœò¤>ÚHD¨è$¨Ÿ ¦ÉÙÒ×Ä; [„}!-»W8Ôn‘»¶€1v[®Ð*h µ GA˜ÐÞ¢ ËqÝ â¨å°n\qθ®;Û”¶Ø”Š )+º¢›Â‰}¥8c¬Ïb62«Áè5œf cS+%ÄÎ5 )¡ûì®aDÉZ_”8šSé %) ®§CúX—%†5BHÕÖ)WOhx˜£oaw¡ƒ)N÷e…ƒ biMÛàj¦TáhE©ßЫ3#–£ÝdxMk÷ìËá‹·/?>!j§1yô3†Cà.J\LâXåªD]5*áì›öª¤Í4þ–)}Œ-¡m_ #Åô©[à º/¨Áªr++ RÅwZj È£ÔËBE‘×Dq…’þÇ}®›Ì+Îào?ÿÝ¡ŒaÉ®ÀÜί¿~ýtïÄBŸ™I3lzh6õ®MLÏÃ[ʦ}mer.§?Ⱦ!Q6˜Ž eƒ*ÙàZ6é•Û$Ê-®å»)þ›Éu; $-ß @Ș2¦i`#Øh ¶Él“Å&‹Ñb´„-!FKˆÑb’Å$‹I“œLr2ÉÉ$'“œLr2ÉÉ$'“œLr2ÉÙ$ç8’Q‡.0ê¬X{b.€“+ü¬ò½gtüÕ^/Äl0$ å£ò Œ—Ãóaƒég4݈9ˆwЇr6( ˜îŽ{—׿\â᳋sŸ|™Q¤(¥Žþ",©LÄÞŠ8„¢n (u|ë•rA Š|]4]âºà:Næé±y)’öZÅI«Ð ÊŠ([ º5cºW)·õ‚FadEG^´IOÑ3*JA@Ï’£¾;A};Yœüº8ùöe ÆDZpJ…­DíÊô üI)mÂuÚìÊÄ×€:¦â-±MÄ0aKVƯä]Ã!ª^¿æ w".ËßØô+¬i÷Ú1¯âˆ®,ÜŒn¥TÞá¥ÝGÑõÑÂç€Ö½ßô[¥¶ðÛDš(•¢•ž~„ˆ™ü‰»åÄt yöûüøôËõb¬J²ÒKêF2‰áàìòê_'‹Á0$°ï_W0àÝT&q¾;zûב}â­ÜÈø£ÔÛ$‚ý· %Œ7¡U{›ðæÙÁÛý??B[[CÎQBу4¨Ý­ƒÑ? Zƒ@ñSûÂû!ï¿úËÑ@·D¢g ÖP ´4@}áÍ׋ӑÁAU_×(P’¡\,¢8Š‚ñ2ßì†ÆKmNBqðõóøÔ¥—`S¡q1á:Ç]JÁ;£y2‚zYïL¡x¤P©§C]cZ‡‰ˆ¸ EíÂAl?ô£»mLƒBÚ™ ¢ÐSK¢Â?b¬{PCÒb1ê-zä!C½ƒQŽ—jáR¼& LÔ3†ÉmKæèöÄ5s¤Õúÿíf'­ÕÛ¶²µ#÷pA÷¨Ù8C³AÿÜâ¾—ñYÑGŒOŽéûŸl4J6%’FÉF£d£QŠÍ)6§Øœ²žcTK1ª¥ÕRÄ©¶zµÕ«I®&¹šäj’«I®&¹™äf’›In&¹™äf’›In&¹™ä¶’œC°A´Ù€m 6H6È6{Ò&5¯G³¶}x1‰ZÆŠËÈ$;+â Ë«-)©DHœÈwT÷“J“›HC ,oÍ*i#b•ò&> #1ªyO#ZÈsÐ.—o pU ÂèR^Ô é¿Á€©QuR ƒ1¬¹´„n¿‹\výIÿrÚÙ§ý »¤Õ,õO´zú)iælqç_xké¦g²ÙgÄŠ„­ªwÃx7_üóõùÈîJ|†;åADÒ„GŠ…õ¨× ª&Ž44•Jê®V×sq"ejõÇ`^¨$Ý Pæ2´]£X[eȾêald0ôÛ)f߶"™µ]3B/`õˆbÕcëˆWuyB±IÜݬN·ç¸üÌúŸ%à9IÛ>\×ðADJDÜ‚°3á!Cs)£·kAð¢½àÒ?š‰’S0Ñï>ótxôêxdC ¢z7EÏÓÈ$‚ƒ±Jë܇!ÐC‰õ¼^|¹<þv²¸œlû™øǪóŸÂq4†Å Ñ<)GØ|Ð3›ÔÖ½êxw52}ä-=±»AŒF²‡ÐûAþmŒä‹Qéë1<¼?ún”8U?h4%ñÛCK3ºµÕú¨%ª~ß™X¬[¬?x=Q¯> stream xÚÍÙ’ÛÆñ]_ÁÈ© ™g1'W)>k]–¥H›Tªd?€$¸D4zµþútONBøªñc—Î04kÇ/O!S¾¾ÆáBÁ¸Ñÿg—'•dZˆ+œO*ןO×n÷%J?(¬µ6}ùæ|ºˆë±(ðiø¹xlãž šaÈ«¾ŒîË4ƒ¾%§mоØZÄøE³¦ßeògì&»iÁäËn®7\öËoõ´'$üçÇhãÉ ^÷ ¶WÞôañeÛ‹€)E90\8ùÃ~Q‚jà ½cz`â$gŽÑf$| •"ìÿ=ãÀ«QºK²JÖ3¡§k¸¿Ìl]ä[jyô‰ê:³ýå¾Àeé£;xÛÛInõ0loÕtoÄë£ù]¼Žö©ÃçDwä~TÀ´i8øk”²e$lT–ñv‘Ö-Ó"JAt\Ç:/¶QuÀo_Àpî¶ëáy›¡†»]$iR=Ž ©óCÙARfz‹œâIÇ)žè¸"Ø®ö¶®ö\”<Ð*qQ KÓ£,JKZ,Ý¥AwRÅ`ˆ·\ë+/â_=Odñ–î&"Í–9)O‘h–…ú= ‘ºDÑ0áµ’þí/w?ãVÜ;%êÚcæYV†áá¶ü¤†éi&;»ÏöYî83ÚíÒ$^1§bD—]¸òÁLé(O°¢ÆâP½i¿9´»Žr X’l¾Ì‹ø&ßWó|mÛ-Û¿}ûm‹óTP#ÑÀxÄgI)hTfÀeœƒwƒŠÑâøΪ³Ã“p¿Zȉg´D'¸–ÀÅãà`›¼t¤]í‹$»¿@¡žyBª'Äïf(ï²L@WÔ§H"øUÞDEä‰Ëšò30wÕHB†ŽHòŽ¸_ıš ¿±lp#n8kJJÐ*à´›<Çíñ (⻫¼{óî»Û÷ÇdC‚',ø•drôˆÒp¦ùN(b¢¾wï¿ÿáö?£Œòe†ñ™'ÂÓcMêˆþ‡å]#Õ³ÖsÐp2úÀ½Ñ¨õ6눹“ƒŸìý@BÊVG¬bÑØز‚•Qá“J(JX߸-Bh«˜ƒ:ÖÅ÷mO5bTvƒÚLA£ÑDô“0f³¹ò‚éÝÆõ¢µMãÊýë]$Ÿ©m/ø¶Û”Ôaí!ìÿP$U»]«œ¾`S?YC6*ÔOïYΙçì‹®ÙI®ñÜ®â%#\ÔÞȳ\¡÷ñ6*>‰€äÂu] ºR©ð8&µ¾½P_† "øq… Œ ˜U0êásô% r@€DÈÏÖ—šI-ž®/ (Ÿã&A ŒäóO(…Ï!û'јÇOhóWJb<»¢Ê^t’­ ‹]ïÆ5VIa³nôÓ‘/œÝS}‘¤UÀ¶;r_?ƒ,…g¶Ü¡ôµNn ÊñqfÔÔÎÐ.Bµk-Bu^^¸à½ÛQ¨{Bn>Òx ðlLn¡ÄÁˆÖ†ðv‡\’%U‚1‡ÓxõÚ_²Št o.Œ¡Y4¾âOo¿9•Ó0;öqÑÓ99öm516ñÚ¦N–BçˆúÆnËbórô9˜?_ÈsÐͨ½¯Ô+MÛ”*| éW0ª`~ñâ!)ãW#á?:QÜ?þ‹k6|HÒ”¶Ù×v p¼c¸ÓãÞTÛÝØ’ù¦ 5:¢ 4omyT,]ë~d|ò;ø4‹¶ÖJb‚é—¼Cˆ+ðƒLxÆq!diä˜üô’v±æRóÖ†ÒÆÄ¥:ªÑ°…GXf3àL?]¥)-m²!)®.rrý'+mÐc0Àƒ>Œ•ÉL9¬ôsrðÆ0- ’Òúlí ûò&Ó™g6•c:á—©oÝŒ‡_0îÂ/86Ÿ~ˆ[\D)M †- È>[ÙLgp \L]]0µ; ýIµq JOŒ˜5 Ào õSèÝË&E½äúµ!°]7q`„DC4h¥Ž`„%™Û††÷YòûÞÚl¨×ñÑÐê‚^öÚìÈéT~Ã’II´Êg*ÐŽtèrAìLïã~z’²Jñ® ¯‹h¤0·¬±Qèì»Ä9yâ¡ß¹Søáˆ@CWÔÂF߇R£ØZ¸)«úýHÖôè“YnzÂJÀ¶7 âýEEå6°É0ÜȦê;°À8o“ŒVßARöB; ŠJ=ÍŽÍE›¬I\„¶Œ0ç’¸¿úì‡\VÓÏ•FJGÕ+4y½wìZÚƒ` o¿Ñ"ÃTgŠ¿Lýiî·Íj-;¼ÛCî ¿B~Šy%Ð9T„š·ÆkBÐÖ·úaTçŽ9÷/T¶z×—ó.êR¿â×¹)aƒªíu%Wúa5ˆmE4µ´{ßcþ³±‰‹Ño”–Ÿ”gHL·Î/ A¨2Ôo .®GÜ1$GÎɈע Nw‹2Ž Êù¾¢MÀÙÔÚkÄØKd~†:Ñžh}R®xn*sÃËpÀñH3¯Ní…]$éé“ά>©s²!åd]uMÃÎã딌M'¨émE)J pWÖçþ¹-Çým¦õÔe0Àȳóü |0ÕOósšNð[LÎ!Õ@ «ÜäV‘e4;qßEž®&Yƒ utäÂÍS‚A 7ÂP.º¶bCQÆË>ˆÁ˜4sÏ°¶ìy„w„vL‘ŒP£}¶ÜPn7hªHd—YBè(—Eb«º®vBgL™Õ¤È3W’€Ñ¾ŸIЊºŒ ‘§ÖáAÕ9Í䳂'ãêƒT2ºc®|×Û÷ëº ^_ýåf‘d7ö<#÷Þåào€½²N"|ŸA òŒ¬f`42,ôù±D(#Õ¶—Q Õß’|ê×/o°òÞl÷Û]9VÔ‡À Ü”gã ±¬‚>«¨Šn^ÖJÀ·Yß'_ŒÁ 1¿ÆÍ$‹snæù{ÖWÓÝ“b€×/ÿ›/Æê ŠyWÙ:4Ì—ý· ~ÆV ‚²kÐX Â!kðCf‚Á#‹í.)öqÀ<ÛQƒ‹€ìÆbÜ(ÌÙþŠf~Øï ¾@3Ýò’mZ­‚ub6·!ùeØB¯¿‹hEžšÆŽ³:¨-*\µ~îœ÷¿Ò-zŽš-48¥½  w˜9¤·”LÊK£Õ:\ƒœY@ Æ 0‰×ØRB›Ëþžm.`@/‰–°1r÷§èu3FsÔMæɃ$Çôn`Ì 8mú¢KƖZX_¡·e›”Ò\vë÷§öw(EtÆëìòKuvh¶9že^‡·*Ýc­¼}´eÛèsfR½ôþ »mÒ÷€j^|¢ Æ[Jnsróðû†Bø6ß`žºŠëm!œ ³Pìge,Mg-£Ìe 8/rà×Ô\}Цd ÑCߎ4ÏV) ²Å§¿X †µB÷‡Æ·MmjC–gUËlMÿ©f¾›G ÒsïõêÇ9ØA°+ª¨§ZÐE&Å*8ÇrD;GŽfÎa¼Îœ×Ou°Ï¾9†/åáp¨Lî³X¸Íª¬ $î)ÃAPéR<åáÕõ*Ûâ ‚éy”MO§û G i®Ô%Â{L[ój¹kòWà“×þÍsí;½²J¶QU—Á±”¼o^«>7iTõƒ[ˆ:É^ß:3½á#Ô¢iÞiJ4ŠÆJ=ôTááãÂI­{¦b¿]EóØýiïÅP‹¸OÿÕyUb¦$¿^ûé…é´}•¸‹è=Ï6Æb–ïÆîÊcBók<âi_©#ÅuØ<„õàa}ÀIè´…bú/ ÀVÿ6ZâÛ endstream endobj 2674 0 obj << /Length 3370 /Filter /FlateDecode >> stream xÚÕZK“ܶ¾ï¯˜ãl•"@$òÁvbG‰,)Þu.¶\f‡%9&9’Ö¿>ýøή¸vœÊ‰`º¯ ·º_y«ï®¼ ϯo¯^~«½U,­ƒÕín%ƒHÈH®t éËÕívõÓúsHë÷Íõ/·ÿxù­Ÿ †ûRø‘sѸ/®7ZÆëW»ëMà…ëWß¼¹}ý³z×r­|hH¦ç >ƒõ}mÒÖÔüÒîÓ’[ž#˜’W Æ j‘Ú-ùýß¿»™cÌ¡’nTzj«CÚæYZ<}VŽ§Ö4ÝbÜhòß sYíú.˜µQ^,â`µ‘žH„'ÎK L‹ëJÔúãµôÖUý>­ëô¡aZsÊöÜ [×2Ø릭êôÞ0uWÕÜ&ç©ä)ÁU"BÙ©gÌß6mSnå–;óëÉu¶?ÏwM€"|½¾í„cMÔ¦H?Š+Ú4°0O€úE¸ªÑÔÜËß]MÄòcáã·[\d/<ëDÐ÷ÂNP(ŠÖ?{žªÔs¯Óã±ÈÍ–{H> ²ò0Ð s×2\ߣM"m´ŸüÑ«;u9™ìép*ÁÂZœ‰µ°ÚÄ h*kŠ? @Ó/ßrãîZyëÓîZ…ë©›¿ ÕÚ$v×püò2/ïù5ÅÑppšé]A£À–Žif? eÀó>ÇQP&8KD"vat79NÍ-T{ÇÛ¡"%B+«s:8|~ñ[8¶ÅKܧ óPV¸K:\ßÚa ªmŽ§€ìÞ›¼$»€&o:ŒNagš¼é…Éí„S“ÒÝÃ2e"EܱúêÍ·o¿#õgÉØa6«vµñÁ#%q4Þ’D&CKÉcôrBâ`w^n²ª¶c Ô‰’DB‡áÙv)õ”(A,Ùaõ—Žêô6edg©^%¤—œéU}Ž^e ôJË[&ó*Œ;V§vSíX ÿÙñx?–«VÁ¦êçj6î4+ÙAcЇ Œ)ƒ<3bC ÏO°p ‚…ÙµÜBx¤žÖvm «çTØ ¼`üÉ0ųŸb¼B›]>ÒŽu•™¦AÇŽ¯ó¢à!àâ+pv†Àèýç{2ƒJG€ïÃ|üp8k}’î` b8pBD ñ*Ð0M›CX„A¾ÚhËoÛSÍÀÜ¡;à`ò3v=’ÂSÁЈ ¢'·] ¯8”B+]”æËHxzbžNP Qù‹Äú@l4§6@uˆ{~Á<ÛºæÞ”6 ÝnZÜDÚR µp€žã¤H”?òÈyl°ÀÖÐxìP@·/ìQ–ZŽ•EÆè«u‘Ö×ÍS4äûËE¼ÒÒž¤À¶ûlš¤ž@ˆ>À¢ÑŸ‡ÁúME›ê«Î$h[K8ìdméi–j¶¬tSXBa±)Û<-XMI €ç"KP/§eé—PQg{ï^ýûͯi‚¿Ý^ýz…Ç[É•ïÅ`>„0Œ1;\ýô‹·ÚB'`¸¦xõ‘† ˆÕÛÅêæê_\L£¿”BižÉÓ¼êëW7·³Š¼¤P©Áû$êiÆÍ•èBŒ‡äTa¼ÄÌ P'÷&ƒ~W«ÑÕî;{ÙV¥lo_1NxŸËc_:¦¡hÚî6=M]/E A&Ð Ö…’O9]Ÿš-5 /ì2© ÀÕc+ÁQû$PL4¯0>Jô8]‘óªa°ÜD ó2«ŠÓ¡œ–MŽ´Ð`Ó£}~ §¾¶Ö㼤=…©ƒÚ–j´LRÛë}’yãÕþjvi·ïd­sX Goh¬dažÅZØݲê¬í²F:ÑÏLáÒ³Ë2¿‘+z½äÇ”Qê`°` <ʹȼ49Ÿå/3æ tÄþtÉðÏ[²O üeYÿ²¨ /šÇeߦDäMÐòó/G1½±_3<$Kí³QiløÔ­=E6ោíë²ãÁ[H¶vHnßô©¸ÇoÆÑR ”ÈèìdN§E’ §ø-åÊ^8ÊxñyƧ)¹>N´½m4€’®Ìº"Êð«Q*!“` ÎnîÓôP¡?M~tNy&±p_76ä&%º ”§ƒ©Ý¶†2•rQ&@.[矧«·ü]Lù•,–•cdB±Åb H°é>c6Kcåj_HýÔ݇‰eŽ¿¹ á¤^3ÚùFtÊš eþ¸ÛÌŸ[–Tä%á‚øìì_òr›gÈ.¾@Zö~¬J¾‡ y*~²—ÁÖ˜!¤q鉦6í©.ÑôhÁr ܼì²Ý™˜Ï¥xUb.1œJ g|~¼*cñL¡ò/¬F9ç ¡Iž§’ñ²"»»© ´=‰œWÕul.¯\ÆþÐýãí×q¹[Ÿ—}éÊ°.Un3®#éÎòjáÙâ>Mn´d\ÞèJw‰ž¥Á2gk¾Ê<ipËN˜ôÇÝ4Ú²{Ò5ªvû#¢¾ÑQŽ\Q„ßR ÍCÓšúÈòöãËóû}»Ù§åvÓ8±&&g €X¬ÞIŸkóø¤²4š#ÕÁ Eݾ &ÏùúÈ ›XîR —7ÓuNp4wÚ4U–sˆï\ßq7’çKú.¼ÏI’6ÛkŒYxM®EÜÇ–1FNƒÛ’"NÌ*Û'ÿ¬¹ÚM–¾þêÝu¢ çƒý›òþ—@nÛXõvκªì„eµµ´giB©PDñçÅ¡7.+{}çKص6™©1`ím¤24/î­^óÅwš9‘zw–Hãà1ws…ö2ÆUæ|p‰¬ $Ùk"¬V¶Õq4LÏh¼ФND’ÿ7ù³½sAýìóÂjQRøV[UÎé›kÿT(6 Tö.ÓÑô2“.ê‘ÍÚnÔÙ®óïHš;ô `eiÇØâG4Þ>sq™>ÎK`F(.½ vÃ5s5:sÅbªHIJÓ^I»äj”²ƒLÏE³Ùß ,80ž5m;¦t…¥¢©f?ïµç~oB¥¡/ýÌbzH7k\Lÿó«écÕ<³ˆý÷‹è$ê¿y±ô6_@ÎÛæ›·sÕtH1#_¯d>ûÕt°î@ñLR‡ö²®Ê ÄñW•þ7Ðr»¯ ˆ;4/_¤¨²úÈ…0ƒÿ¸|OZŽŠaOþ÷·ø£þP«àvè­5Gnñ/±9¾Û$ÿºã»_þü¨ƒlþ ˆÀ?ñÿ{0¸Cˆ9wôÿ°D~©‘pÒÂóŸË˜•f KÝÉ>ŽÔ9ªìôõ.WÓ°TŽ.x<¡U4Äó¹r¢¡agXéä¶Î#€ Þ(Ž]c8t pŽõÀ5BºÈcä(KTÿÙÌ$–÷ðé&YRæþn‹—%8öRêÖíS¾!ONW.ƒ»°¥—}ÍxWÝoRÓ )}j5®Ønæotn‡Îµ0”uÉïdƒÅI/ØVOcN"âØ–FŸ”ýJXÜ^ endstream endobj 2712 0 obj << /Length 3317 /Filter /FlateDecode >> stream xÚÅZY“ÛÆ~ß_ÁGlÕrsá°K©JbË‘K%;ÒV^lW$±"J À äÕ¯O÷ô 0±»$%%O4æìéók„‹÷‹pñÓUøÈóowW·/£p‘°4ŠÔâî~ÁUÌxÌQ¢—|q·Yüüßg‡²»^ ³ò_ÿq÷óíK™z#UÂtÄaZ3ä»ë¥äaÒ˜ßCVu³ËJzoëòÐueߺ|=8Nz´ÅÉþ–v™%W,UŠ{U­ëÝ>ëŠUQÝÃÌæ´bq*½ÍÅ‘ ^uyƒ®…>^sä°$ šü÷0U¾Ë«îH)|išº¡¯Y••mÑÚ/YµAºº­^ïíÉ ÝÕô„óú+ô}»&«Ú}Ýæ4Gû¬ØáöK»ã%YªSÚ7²Ñ2)dÀj¦ rɽ¼Ev)Ÿ]‚¥IäŽýêïoî^ãé·o_jáߥf:Ôn\D ÕþÄ¡ûøb†Û)‹¤r¸Yl)b`V“S£xÒoèåÓ6¯¨E|†'øòaǵô<´n°á0<›¼;4¦d/sÝÕí~ßÔ»É Õ¡,íìûl[ž'Œ ýmx.ôsL×!‹¢/๠S×!ĵØIúIj=Ö§·y™u†Ã û¬A~f»ÔåtºY=™ÐžòŸÅ°vÀÆg6µ8Š÷g¾9oQÅT"U¢ÇV’‰PM9¸Ëšsœ‚Þ2ö-Q¤Âà‘FÅ#+ÐÔÁ*kQÞ±‰æíÐe¤†UÔe;“F`‹Ô)‘aQ—ÏyS/÷Ö̉0¨;ê¸ ]S:»eæÀ{ÎZÒ »ã‘V4ùykd„§ü%‘)\º:…ÿÇZÂEr±š$,‰“‘šÐ 6‡¦¨Þc;$#Ä{Ã4$ÅgË|$›‰ÕHê‡ì²®)þ´Ÿ-i®úPYn¡ÍÂï+;fcκCOA#¢¯k†Þ¼üå'ÃàdŽÁü13ô—Ó-gJ`imC‡7u§”^Öa+¶lCÚÈRã'²ÔÔÝŽ#K­n Ñx¤y‚ˆô ØÄ1 Ð—ØkÎ"~ª“„¸% ÂnòˆñÁúášYÈD«ºÛÒ¡Ö MVŸá”†Ñ:0)ù7rT§ÙÝ^‰^X-©²ÑP*ƒMÑ‚¬ÐÜÈ“À×ów+¦¥þò-òa‹.´hi£dõZúf¬*RQ3‘€V•ÁÝ)¼º§OAxÑ•pØ*ÈãøJÐ|K0ïþÂùœ€pP¦_ë²PÂ"G©h?¤lаÊ-§lÐk)Hû ñ@`/w04m£ ƒ µŠéZYÓd–{¡` Wcî½ýÇ;ܨAV–õš")ávˆL3AÃ.-4ÑØ¥ÿ´­ÛnPƒ©À ¢Lb. ¨G¢‹Ä ”KÇ,V_It‘Zº ³g ç¢ýHÆœ³·˜ðþ“é-Â7ºEh4Ã&öžëÒ¨Ÿ½§ÓÏ#Åø@¼ûåµÿãÝÕ®¸1‹|!E ;– ¡@ëÅzwõÛáb†ieš,>™®;0T:œrñî꟔³Žc .KÑLQÑš 1OqÍ®BGˆz$ø¥b½¥3ïmG­•eŸ/ƒH~q©t õ&!…íp1¾šÌÜL((8¨›&ê¡ öM½ÎÛ–®'$‘kóüÆ/~3ƒßV­ æp0&ïL`½ š³”¡¢U­—!ë¬Í1«•Ü9_ V‡ÝÊœ ºÖ÷¶#¨Í®²»$¢Deµ„æI$]h Í)î;úîß%hÛĹú}mmÝ&ï²¢lOA g)Ç&b©´2ò«¹Èã#™¾ÊǘÃtô›æzTj3>ID  µ\Ž?úìIJH‚aׯì°O… qn;f¼bVƒ £ýŽ±JÝèã4á~â5€„4ƒËËbWTÙp…uû¼Î;‡ÕõÀIŽÁ ÅŸŸ!«¬FŠóºüd_€›N æäy“_¯!̪۶X•¹+E4Eoí-Ĩ¤|°| —ºüH9óÔ¥ƒç“\^ˆWjíƾýñ‡g¼¬í¿ Lùzf±gáÉH3©âçYYB 2W9‰Y!»Vë— ûäšlÉ绩}Ð: Ú.«6Fªcyª‡oÖxÇ*É(ŠªË› cÓ³©a߻ﯗiŠÈ?ðû¼!ÉÇÞ…†W5a§-Ñ ÈôŒÝƒAü>‰Mý [«9+ÜP6PWåu²8–òŠ;`ÄÕHA ƒÿJÀ]h–ƘÌ|á@ØI" z½$‹t/)ßÏLb¥ÓŠdÍ QÃ2ÎÌ{jn3z é«$ö§z1³ç ¬ˆÛÑjf1 b•Îž|T|`Ã…¡“IåµÊnz7ðÔèR˜)rÛÝä2þצx¿í–[fAžæI²Ý«Cëºiòv_W›Þ%.ÑE1Ö÷øç¾,ÖE‡bC®¹Ï`ÕÊ™ñúÐALÂ&êØK­1ò'ôq {Í«6¿mòÍaSIÓ"\Ú?¾y·'M#Ú…ß•Ž¥u`в(øÅÈ¿)ÒcìÒ`Š±KKmmž½K#TyNï̉‚#Ä”ÿH2x”p˜4þíL ÒŠHTœ®–æ "ù#FÎÁ©°O01k¼Ïaþ†Þ>Ø£­Ùû$·%nE2 nonû7–Üó{‰¬Æ0.în2jÚ—ÞíÝD„cás—9J†X§(32ù@6Œd%MvKq“ 5!B¡v¨\Qm¸H/ÀC)äìqt¹µ»Éìþ,X­•Ý Ö mq 0`•ÖXC¤×½Ì3+;ð²) Ihmävúá@ùÀ)êIùõ §LYúx.NÍÄG¸çgê©þkÅ©þ‹'ôßZ²‹’Ш5SØDN–ôÙLÖÚã©ÜfVÝ º:Ñ&vf !ŒW©8“à¤tïR° Ú†ZÒ UmäÄ´ÁHH’Dì G225ñ±©IìHo„ã!4'§‡{&½ÀoVz½5}éEòÃdb 5bÏvNs?å&aA‡gÂa° ]K„^Àññû dœ#ÎÄŸŒKg„[Ê©x++ÞÒo¬¸HÁ­áÃ>ÙúƒŸµƒH¬+ºþ"e"E99k1pEcÖxùO±ÞbKº®Þ{hCE$ßÖâ;ÙZ3ª&ŠE襟j웵m½.²nºv?@"¸£¬‚‹!5s¿SiR MTgźÙEÏ;P¬rMÂS»±v„ S 9ñƒH*ìÓf¾Ð²ÎÆø{ßÙÀ1ÐßÌ¢¨&‘Ñ.s¤ñßa\zKÅu[m†¬tšzüëšsP&Cù0¤Ö°ÈîÁ´˜þ‚– ŒÈ…BCL²®É‡¿`2;cxÒ_5áx_ßøÿ9“9ý¯ KÀ¶"0…ô€È±æßx_0Oa* Ú•²€bÿ­Ã¦û·Î½m¨Qÿ§‡dÿ?=Z’*Z¡©á¡¸n¾ý¯tœŸ…ŸÚTâ K«OŽAkžWF”( "õ6}tEM[vFR1ž*’¤^<ÁYœ¨/ÂßYq2FÅYýG.€’qOÉè1„OðíÂü€ÃŠÉð{ìi±Sûª|Z]7<îaÏ`MÔ#UaLyl!ÝßZ8„*)QPÕôÞ—R"¿”B.mÝ´âÝÿG •Rn¦e$ë8øbäž]EA¸Zi žt@y­ ·@Šq%&¯›)F¹BÃ|1*~¬³„÷U@È!º¦.ÛI첂€ýCú´ÅçÈ·Á lºØ;°u”¼››!)z×,1ÞEÕSèk¸ñ‡ÉIlµdRKè?ÏÇ’ ¡~$ ~Ç%þo™b) D8¶Fjü_ÂwWÿ+îò7 endstream endobj 2619 0 obj << /Type /ObjStm /N 100 /First 1011 /Length 2837 /Filter /FlateDecode >> stream xÚÅ[Ûn\·}×Wð1y‡Ü^#@.p’ÂM Ûm?$ŽÚ M¥B’‹´_ßµxÄ‘…Hãirt86Ïrs ¹/korÄ{ )ˆ÷²ŽFRÿOAñ!9¸*JkhÙذЗÎrê£S Y$Ÿ U!Òù.C¸õDECv­lZm|Š±E(×$äjc†$ù˜¹sŽœ8,³…¿Ì sdäVø¢ª[@ÖŠà+¤D ¦Ù8]TêøTƒ`Q7Î&´ yR‚¶ñ=¤b!|¼kÁRòz0c±h¦c¬æ`ÖÆ; 6€¬›UåljÁÚ˜×,xâXÅlž\OÐ*h¥HÏæhU .…-E¿âœWѯv~,¢wó¶€UŸöPò"%ÌͱU¬&|+ؾ4ÞÕPª©al«cD5e~KO¡æ±ožC•ÆO]Œwª/ŸZ¨¥ñ¹‡Úߣ`™ê¢ؼ–†þ`+ð!góšÎ.Í¥”á¢%¡Õ¡_úÕÓèK6úyè¹VÌ]—Okè¶|ÚB÷:ÞõÐëØóŠ͆Ҡ_k™-ôãªU ë½þÊ)AE¥B¯rÊÎM¯ M/Ä_ùkÃ&”;5o+5¾Ž‰ ÞøßK™³4HÈ:ôSgˆåRá9çe/¡ü9c31t*ç.£¬AÒØöFSÊ}Ãl¢C±â˜a@ÇÖäaŸR`!YMƒzdi•ºÐª2g† ´“'ONv¯þó¯Ó°ûäüüâúd÷òí×ãùÙÙù?NvŸ^\þxzùm‚[H¯w_î¾Ú}öm'»§o®Ã·R{膺GØ,+GÅ*i±Xº}ž< »—a÷ÅÅ«‹°û<|ðõ_üýêÃðñÇ'øóÛÀ1E§*[øڴŘr¥ûŠ¹?áÅ—/WDPkì4Dm1CûLÖ›b-J®÷"ø곯_=û¾ûp= ™K‘.潞½Ä‘GÒ(ýY#Üã!*kâ€Gˆ¹µý„Ï•(4™Žý‘r/Ž«·?ð†Ÿ]œGÇð˜×\˜3¬Î+*™é2Zf~,"Y‘ô‡#÷ Š½*txnùþ½ººøéÙÅ› Èý@—hTš^®=·È)o 쥕Þ­¿…Îá1&Ä<Ð,bȱzaïÂù›[`…)¼»?ýù/ˆq°>ÄdðŸó·?ýôúÁŽ£§Á·wDûãz犻ÓûéÅùõ@þ|Är^†=E$&ÛZÿ½ÍLWrÝÀÀàn>¥ªK7ß=¿¼xóò vÏ?v¯N¾¯ïîÅóïÿvz²û Nϯ¯Hl”ã¹äWo/ßœ^-$k¼ûãégßzñs»D6Y;Wþù÷—p²L~²ìð&Ô”x3]9ÍFž ™ »iÈì,³³ÌÎ2;˾³ÏF™:†L:%딬S²NɺH~½’kCÀoàHìοFr8]ÝÆ‘ˆ&Ï· JŽ Î‡0¬íKÀ:\dAÌ´lÓu@6ùüQFäÝv!è=¨%EYF–;rÐéˆöý ñõÓo¾û@tM FŠÌbAf{`ÆÌ~‘]E…‹#k¤á#¾£c¿¯ÈF,™‡wˆ•2L¶"7@N¾fÛñVp8¨=ª‘€c€¬J\¥"kAZ­L%ÀE@ä„ÀÉgóýDà›‹7¯þù¯Ï.WÔÓÈÄrŽ5¾ÆóËÓ¿žý¼¢zÀY°†aÍ£3½±Äűî`õªë®‚6ëŠû¢%Ö ,S™0wØ®#Ó*È:Å7Ûˆù- ¸•˜ú{a¬¾1Kze Ƈš Ò;84ƒÚX»ßZþðͧkz²6¢Ë Ø®ÂVóxyå„àÈV‘ñ7„\Ø ßûvÚ0“9ÐÚÈ‚ÓÜ–u ¼ÔÍ´1¾azÄȤ¥‘´#º8˜OÛ@¤Ä”JbciÕ ¦ðH¢€8³z˜3Y[ib/Ìö}Ž DiÍ@†Í”ÌtÌÈ2€¤€Ì(fw£ØH²LŽÌÝÞí8³1o-ºù‘½É›;\ÊoËÝî¦kï&rkänÕ~™»Í”ì×än:ó)ù”Î|Jg>¥3Ÿ²™OÙes”ÍQ6GÙås”Ï,Ìgæ3 ó™ßù”ìS²OÉ>%û”\¦ä2%—)¹LÉeJ.Sr™’Ë”\¦äÒWM› —897rØÁdrîûMá7$¼ò(Dê`r‚d #'QÖÛêv8GrƒÃÀt+”ò $!_HYuA·„‰ d’G!_6ÂÂcë‡ÖCV­Ì*‚î‡6òî~DzR¡R]€æ}¥ºdP^Ýn9,×ÈÃ:åfÑÄ b3–/ä@Ššëª»’Z¤ow˜iåñ§ƒèGÃsÕíÌ…ûÚZpäÆ•‡„Ì„¸>…Ë·¤]zåákl­Æ_Ó”÷zõ(vk–AëtĺÀ¡Ø1@Öµ˜›yh(TE•Ž¬1¼c‡î÷ìÏÏþMbñììêzM’£¦>H?D:ÛËh9d2«êV#‰Ý¢àa¤†ñÑG9­O9áo>Jž ¢ÈÚa:÷"¸9k[U- ãJßÃЄd°ç#`øºÌyds ×bß!Óq¬\u„ëD @,u8;ˆøºnÉRÕò2æ‡u¼Ð€p³[é³S°ÌQV& ‰Ô–D o¥s1Iò¸*uɼª„¸_tCïÅ£ð ʾRXé< dºó¶ê¾˜3Ï „'LèUÓ÷Ü´0G‹ ùŒ¢oÕ”X_ZX×P´2‚“!ƒ²º¤¼{ã MíºOÞ#?3IJÚÈ;qˆ)}»Èæ¬}ë- PÓ>®Ù<ˆbÝÀ/1nmHF`§çã\÷{L¶Ûý 8qp3¯HðÄþ FsEb˜W$Xý4J™°ý]Æf+Þ™7à`½¦ÿ¿E¨ªGÖ¶Þí¸¯mÁy¦¬GöÎ<¯hïë,èä¼*”¢w}¨v§ÜõpUìn! cjþe!ìN‰ì×VÅj–_TÅêrá×UÅê,,ÕYXª³hTgѨ΢Qå¨6Gµ9ªÍrT›å¨6ËQm–£Ú”ܦä6%·)¹OÉ}JîSrŸ’û”ܧä>%÷)¹OÉýFrMi6òlÈlèlØløl”Ù¨«Ìnê⡲ZÂ#ëÍó!W×£b]nïíÞíì²](f9š;EÓø—9gk<:O<;dåóàZ>¨ð„ü(+×CàžX?k6&y Š`0iÃ?¾!ŽEAxNßxÿy*È¡súGa­¼]l£.…yálAãáZ½³Úë[&WËzå|»^ñ\lK=å=AÝQáI¨ý@RZVì‘çâiäã^Z„݈%²v¬€ÕQ1GžÉßX ͨV¶¢ ¯² y¡ÀS+¯”à¹Õm¸RþŠÀ…µþø%: ¸²Ð‹G7i¸ ÏŒ™ò|*7Zíôè}Áð y‡ÿ„u4ÀMi ‹þv¾CDøÓŸØ¥lçKçÅMk5 k#p¦Âë%H{ú–N}”¸ .ES]*Ü•¿™bÌ;˜î­N‚xÅG#$ØŽ =±¢HxŽ¸õTÖr˯ËÀ¿ù2Ì%ÖšAϲû3Šÿ'w# endstream endobj 2744 0 obj << /Length 2827 /Filter /FlateDecode >> stream xÚÅÙ’ÛÆñ}¿‚/©«–£Á Î$J•£X¶\^i­ÝT*%û$‡"J8h’Ö_ïîé\Äî’+%zá\FOßÝ _¼_ðÅüžñŸ·Ï^|±8¼Åínáz!sCwD>s¥»¸Ý.Þ9×ˈ;e]§ëL-WÂçÎǤJXÕÏ’ªZº¾“ÜÕt’KÎËì£Ú.»ýéÙKñ ɤ+áíó_—+éÂCÛ¿¼~ûã ÂÑ8!pe1¬\…\ÞOaÖªz†?d§áaŠI óHáƒrÐJ»›5’ƒÖúJY'±Ú”vq>·]²¨§ú\~w>çGð‹•”€£ð÷q›.Ê À„/Í›±-7`ã•Jk̉ÙwÙƒ.ˆ\ˈ˜|‰ºOS€º‘²Ì‰ù÷ì1èyÌ©]ÒfÍÀ/Ï\$ãݲŽ +)N{)=Lo„â­Ê“êÃ\.“á0Qä¼ú<;h2\¶ªØ@ô€ÈY—͞δfã$WyYÝѼ­“÷fÙU+u¦21 ÂÞͽ~ùæD$ùcÊ ŽXúÝ=’b{î‹YÉã÷ºç9-rx}¤ ã“öaÒ@ þ؉AÐj›]±'=§IsÅÀ+Òù9T"rÞ«ŠŽ>.$:Œëu¹ÃÑŸz :ÌT²5K³3A× ÍCü½M+•«¢1È ñ0¡a ñžÄkð1ý&(' !K0)¡Å®0 Þ¨CC{è qÔ*ƒ“!5¸¶Ôà|L~¼Ø¶„ÞuêOÚ:=ÀSµCÎìÔ¦©‘À>W¸s»ô|§-l†ì#®É0ÒÎ ÇM•B2’d໇,ñ„heEþ7ˆ}S¿ì“z.*jXoǺuTìK«Œ‡ªDHZlÛª«/:ؤH²»º+7Š“î°2„ý/Š0>g2ŠÆÈù|=Euê¥)¥6û2ÝL.¡]!&P„ÊEeT!Rq1Tf Q„ž‚Nš=).À à`æZ # GGßìË-؇jÕЄwžƒG‹ãÌ7|Ô?,Žãa®`îqf¶²’0…î}±%~4iá,è\úŽÝÏ8UÎU‚Q,ëtQ“`Ç~²ÓãÞ éãN¨,³cãÔÅ}à†ãÔZ̪†Áš/ˆÝ‰bx’;ßцD8e ¤Ääoôd@/¬ê»|]fZƒc>£4&Í8ÆdAÕTFÄÜhнðñTˆ;a)*pØ÷ UÂ#/1WÑqΚ}Ò`ÅIˆR>$öê3³1 ¶wB `oM`(&‹àMô„a{m0&KÁM‚—fØI24‡†ï&ó®ÒÏsIM½/ÛÌ8¢œÄ` Ì„Ϩaä<_Vu¬¶mŒë=§þt™ˆå¬Ðg¢KRf´™¦D p|Òâú®@±g_R„Ö>v%ãúSše>Ì•ü$?ÏÇ5ÕÓ+9Þò¤÷Ev}z}9,õ k^h€rfis7o:–|![›’ S˜h=/î­]”M4—à(EF€.Ó¹ÙìÛŠN‘¾L'øt´‰´•Kk“ô‘#Z{ô””ZÆ0Ž›hn|f«Ä½D‚6p%"@«m}€» yò9ÍÛœM•µéSÖ[qSkO/X¹ªZ&=À¬|‡„¾TQÂéâW—™V7gÂ?*LNäDíP\ß.cá¬n^¼AAß¾øÑÈ°h;ÃjLíS)Õ‡†c{ØÔeãåøŸ4GÙÃÃäÎ7¯¯µvVWJ%©ÇØÿ‰R-Õ¤*ú ™ª¾;fQd¢gŒžþcbé endstream endobj 2788 0 obj << /Length 3899 /Filter /FlateDecode >> stream xÚÍÙ’ÛÆñ]_Á—Ta«´ðÜ\å;‘¹¬#Òº\‰â,jQ"5Éë¯O÷ô .b)’»QüÄ™Á\ÝÓw7ÙêÊ­þþ„ÝóûÃÕ“ož¶ŠÃĵºÚ¬¸ŠBñ•‰uÈ%_]­W围۶—B³àSºíò‹_¯~üæ¹LF+UjÃa[»äÛ‹KÉYÀh͘fi×V»´-2Ênª"Ëáǽön6»Ö¥Ûý’«ÐpCg¼Í·i›¯i¿Û´¾à:Hwy›C‹ÍÂ# =º#ÌB õªÆ£}ç-ÞAï C ¿öÅ__]ý„`‰ø^îƒ%Ò¡ÒÁyXviýqéÎ’‡2’#¼*£ƒ×%àWÄAÕµ·]û:* Ú›œFo«¢D,@' ÒºNïNƒ”s*ÑÃúî_/íúgWO~{‚Øc+¾’, ’+£MÈ’x•íž¼ÿ•­ÖðñGØVÂÐg;u·¡I ±]½{òO"¹Éi@'¡”¸“cXfÏ|óìíË RgX*T:ò7¼­+|üOÅ:oi–åMãS•„ŠA7UÓ:TÕN¬ê ÅÇŠ¾át¸fUÙÀõk¤g쯻º(?ø­rj¤eº½kü~·7i“ã#_Ö§½1b]‰ƒ/^=ýw¤çhœg˜¿ô+ î½,Îxâ®Ê2k† €áêÖ!ÆN±ˆ9Ÿ‘OÓ††ïÇ|ìš|žHÄQêD&b%C…D,UÈDÃÊ€¸Äd˜ÄüHæ¡æ‰¿ "¿@äã‹JCýï|/ ËKÍMðʾEßMµ]7´'ÀúMáQ °!ž,æSþ„hNë"½Þæ$C ÷SÒ¯ÝÔÊV÷"‚•ÓöyÏ`¿Éó/<Ïê½ø®»nð+wˆõ,¹‰àIÛHégÓm·Ô&ÏêÂRTHS‰1^xM€$v<“×’yŸë/P|Úø×ȪV”&J¼P4 j¼.~§6âôˆÇ¿ õ¸×„÷‰ËPΨàá1V‚xnBãAyƒBrh;WÎÌÒÞ¤ð"x Mµí† [|ÔÝ.Ý æÍE ¬Ô4EÏ‚ŸC6߀޶Í]Ós%ÒLµý”¯àá07è|ÛæÕ¿÷%¥È€BµŽœ’ˆJ'a¤h'í-¹¼;$(9 ×^P>= 40â-¯¾pÒT$Ÿq’òkýAS}£eÈ”y,J0–"i&X|÷æû·ïžO¢D|D¾X„Oqk­>Å£P(ýgƒ/c×< |î0…ïÍÕÛ“ü ®Šû¢H‡mɳÐÀÒfÏrb÷Rj[—Ñm^§c¯‹†ë-Ü2ßšiÅçMpüVVnèÚM÷ ö]¾l/أ߭¤™Å†fö^µ»íÄ ÌªºÎ›Ûª\;×1B×D X\ õ-V±amnÉÉ==À1¸†½oÀÙ—œ_0DÅv8Ùéæ@E±Ù?—é\àÅã‘«È­;È‚ò,·„á¼Àh` %'pÆ X‹Z?cD‡#‰“=Æ°$ •4s ê¼íê¥ O<[Ÿ ÅY(Œ>h… ’«•‡žÏlYf*Ú)‚Ž5S0HÐß} „Ô¾O¸N¡[ÍŒ!·â×MWZG)µ¼oçùOE/¶9|.Úšã6g¦h€&®Ñ}íZÜÞ™±¯4aæá7Bˆ3øLDa¼Àgâ+1’ú+)®¦J¡hèžV‚bãv0Ö W8\“¿ ÝW -Hë¶WÜEvà0=“¢WËZðÚÿ°IåŽ,°•âÞe7]M#ˆÆ­“õØ?C¨¢p"ÕƒtKΓnB¯}Ø.DQYî•)` ˜Ô t RÂÒ£k8cÏþšx™,Œã^’ÎÜß<~2‹}úÍØ! ºZ8&ESÉx‹EIó/£ 9Ž=rgE9kj—§%`r›7Þ,×>Òy‹ëC l¸>.üaDÈY2Ozü8ÑÃ8æäF¿Ü a¤¸oâ…9§àY·np¨ Yü•b„±ä{‚ ¯Yç¿ÃÐZËOi§q,\MSe=0‚àd=€0ï®t’m‰Ã×>ëb(X23É”FQ;i Vè¶Ê>6Ô&1™MñG~}$Q8°Ä!ú8(¾¬¢’ÁOHÎqð!¯OÌË0×9ý`‚(Ó‡Ÿ&®œð¦;¶v6÷…­mñùÌ&Y°¿Î3ðóHÝ$ƒJ¨hf¤»ª+}.`ã"ô½Úq"ƒ¢©ÍSï­ ™Ôß=Û§Ûm¾-šÝ½‚„L—å±m±sãï’PJX\cÃæ¥ç¡å§÷N¶{)~â¾w¯ä{³iLá ¡ÀtŽM)ØÖ®ÃwÁ–Í.lâoQÝcS[MˆC)ýd©õÊÈÒ·¿­ßpÔ{tÜ% ýv³©6MÜœ¨{m)ãpÌ |p-5Æ%’dS\ alµ'ÄyÐlÐv2òl‡ >Û÷P–å& lR‘' òˆ°ÓÑ.¨"Ó/Ä$ž×K!dUÓ;†(£tBTˆÓΩ`"Tƒ¹´î WTò‘`æ*™œ‘æ¦ê¶k‚ö:'dßT™3@p˜|#êyn0wW µ]€‘ù‡³u0—ªSê)U¼ªÐ*—Ðe¸‹@ •™lòmžÑal”ÄŽ ÌÕ'àÀ¤/à7æ‰1`´@ÒN,GI=L˜©³Ó r(ý¹¸È„ Dù#%pÓx ÜQ¼ òë!a86ú²èGOpù J… “Ñ™o@°Xô1£ážå©;’ñL/| 8À,™•€¬»Ûm"ÐQcm1¯÷ÑìQ±Uo©å¥O™O6ô6šÛÂA¡‰ kÙQ¬oÑHú¥ßvr‘EW¤x½ÿï@ÿø%\®âDéàGûî¼dGXÿ¦¿õwtœ¤wÓë­‹&KëõÁ¢’½€Ý‘%%24ú”zu°Þåúnv-*“¼÷ÖC:éœR˜ÿYÞu›q©ÃÅ<.…+ Ÿ¾$X®ÆyÉ·-õ<*°½°Ø= ;‡ ›9ÊÌß³~›¢œm‘õSm|dü ,—Ëjs™U.o°¡9}8æ K¥Û ”BWŽêUñƒ53^‚ÏŸ)%ý¡0´©jªÏ¬×ô|ô]Qö{ ŠÁ‡>÷G]‡ /ÐßQ(}Ž˜d`ÞíGš¥8FLŠ±˜T†Ä¤Õ–qð¢¤1Ê»àå2ª±j0æa´hižÓh0BbI9 :â«Q)/Žó¨‰k.|-/øO}¦Œ9 뻈Ì^dˆ¡7f~Z 3Þë”yƳo/¦œh(Úé÷^ì~®‹¶õŠ¹­úÕçµ`·F‘Óèñ¡R ¿LLY(×ËäXˆâx_ Ÿ(é9YÝS;¹Œ“˃vÁ–-¦†m,|vKçÇ…ÛÌÓ5¦£ý×¹”‘ ¶E™§5µ›;Øh‡miÉüÙo]ŸÏGP>ì¼XITõ)©¥†Ílä DÕxg ٠©×iÅ%ˆÙ¨W+/~ùfI™K Û÷®x¸Ãˆ<ˆ¹HÀ¨ë7þñõÇW~'û²R U°6˜™Ey®¬ \Œª×)éŠc.A²é¶Ô' jg—TµÎƒÿдEæÖlêjG-—©_POé¯ M‡NMÝbÄŽ­‰Æi“tw»™Ñÿ‹¦—·ŽÝÖTÁQ»º?C5D†Iâ¡‚ÌWCcùôeëV”ÝîšØe˜>T@‡X$™óo¤ú 4a“Nº¥.–”Œp$XRŽêðÃÓ%•ÑŸm 갴и0¦U+vRí&Ùrq™T¯7ô•‹!ß©°I¬K£”•ÿ8Lò_:µŒxÀ=ÜóÆ­Û廪¾£vŠÐ‡’pdãoáƒèG(‰TSP½y1þØ ç(l7§ö¿V>†¾gžGìÙÑ÷ öýúk€ÆKÀ‘t÷X„J…1!ÊÓcÇNøúŽ{ŒÆ»»×ÔSóÅ.ëÍì‘ä‚ÆMêF°D »[ßoíîÑouŸ,÷»c •ÔîNÚñí¾ F'j,?/Vg‡‘âK:wµY\Ž MũÍzÁᦢuoÔ½\ȶ]3ûÝ~®ÓìcoÙYñ'á<ÄÝt×@Ví(ÃÒÛù#ý¾ùÞ¶ñžÁ¹1FÕU|‚ˆWs oÍæ¶/-§t¶€¥>òìòò[÷Â7’Ç-Ç Ž†Â,UÊM<‰Ä+!Å¡Q>ŽUaklrPŸfö‹)ëéMoW ‚3Rê’°ÃVäî]§ ¥Žü“Æ^l΄bÈ(©H}z=Çþìf ãp›„&F=±v•‰&kž]=ù/þ‚@] endstream endobj 2832 0 obj << /Length 2996 /Filter /FlateDecode >> stream xÚÅZKsÜ6¾çWèHUYÞ$·Ê—lì¬SŽ“r´µ‡dœJby†Tø°KùõéFƒphyH§v1x6ýøº~uů~ø†ûïw·ß|ûZ¥W K­ÕW·wW–pqeÄW·‡«ß¢CWåýõ4n-mltWÕŸ®²ú@ù±8eÖUIEƒß8zÌkè|Ê}¿žr,³¹©ömUN¦øGp‡3æªF6õ?ÞÿÌÒ|B¬T ‹¥éÉ}óÏw·oq%á¿ðs§gÛÔ ÓbØçKýÙõM*Óè]Õæ8ôêF¦š)!B¾µY ôj…LÁ‚Žº²y:ò¶.öÔrÊ°œ7Ô\”T[uíMuw³¯êœòòZóècQWå)/ÛNO§2*î¨?ñ ú…܇–û¸ÄµˆGôì”'Ç¡¸ŽËnz,,V¯?¡8‹S±á8€ùB çø’p‡2ÐZŽT“lëéq¦°p?üí‚X§Œíã~iJ]üfGl N?ùºCÑìíÀ?’ÍA;mÈãA;¥<ç%ÃyDô¦¤ööWÃÒÔK›-9SIº…Ñä^N¤8F£éI´«Ú‡uÄ(Ëb•œÓ"6ÑÂé“•‡•¦ÚÚ TÜÈÄqx¦/ÉJú“ì+i·)؇ß©Öï$_xK©CÑGÑíÚÞÅÇiTÝÑ— x6¸É²]K¿”LŠs—$;?~–ÆŒ>ew¹U ˆÏc¶÷dﲦhÖ¬ã|à/J 8tøžyŒÝ9½ å«ý>?eõ‡%ÂU¬S­¢×¨[N“­ )šÐ^—ÑÉ[ýôïŸ~ù•Zö]]ö<>ÑHwšŒ%a×:NžCY€ÆÅÌjhU„7ò2œÊ”yhff&ĤlâRŽŽ“¬~IµŸ$®’ øžoÄ«±˜\\_ú ÂZåðÖeô¹ëÚ®öÄÍÀàš‰•&=ß œƒñY†¹Â(ëçq®Å"Ð…• O©;¬R”S–Ç)Ó2Yâ¹ IãèSŽ ˆ5ø ¦J©­z¬—’À±N䑬ÕÄ趻Á×ÎBGîÙ³°Æ,‘úëyá£$¤á”=3Žyv *‡ &ógœÀ‘Ä\âÉe8Rk°`#-jL´ýâƒsaq"¦§ŽÐ±ü\ÓN»§™ð>TMûŒlgev|jzÌìâ’Ëèö´.ü—k€)UÓ.`QÒBôU¾4ßf5¡a—hhŠ].Ê5ÌÏJ_3Ù«/óþ_¿®D=2erw0Ás›2£©y±6–L;øª V’ŽÌršŠ¼y$>­\_±Ä{ÿêû/ ÀÆÓf¿¸˜†i’@¬w^€ù4`PZòÄÚµ ÐË”“=#ä.¥A錅Ð8fÜŠypçÄÁœÖlr>ëôÛ16jZ gùGw.áÌ~!¯W.Ì΀‚ Z?õ.Fª»Cå8ì3ñb‘ 0TÔéÌAÅjãÇ<ça4G¦·_X89ø[¢ÁNÇO `Ã$EŒ?½YD_ñt:áK®jSŽ[ óu®Š‹èÖYn©ƒÔ§”6ÑHØŽð~mÊÃ1X÷Sá2ÐFék¬ó1Ô3™œP¾ËöFir[ÛmçØM9E+™˜ßL¬•±bèÏÉX˜Àœêåÿ+ižM`š©qq`€»\21>ãÁ36×YÎs9ÐpQž ¤ßˆÿq–p!S´90¹.-8š/f %(L2¨õyU0V´ß]Þ@L[=ú”ƹMÞö“}ìý©h¨­cêÓ S£‰¿}d€Ý6ÜIBÀùžqŠ¯ ì^ÈŠnf(¥'áÜuêœÚ6ÜDOå¹\¤ › n£1¿Ã‡ã´>Ù!½²˜ç ÃýU"4â^8ä§ÌÉ˶.² ’—,1³<ˆë9 zóM¹œ|sÀ¦˜Yº<ãëtyj­9zm–×]â||"àtŒpbL¢AµVÿÿι,s¼¦š-·“÷ù¦Ä†M ¤™xc^×.™åêúHm•qÌŒ>Ï¿±NM'Dºy(Œñþ@¥œëík@‡G€Ö`´£Eì“r‰ê3²øPÂéñè£ÏˆC¨õm¨=GÀêŒãÌ€á‰EƒªÞ¢%=™P÷XW}¤ìf-©º*=Y³ø¤`1nžÓmþèÓ €ÑêüŽd/u¬ö†ÉšâÏÍz$ÉBŸ§re¼Eæ¦÷fÅ} ”.ÌèÔgw¶eòuš¢E9 Ü’Š§®i©´ë…./_Äœ~»¡‚¼$¾$éJ—©Áp ý¬_rCì¾Mã­‰GÌú”)°Ë$—¦ DK8¿¦iªîˆ" èÁ](Ã4MàÇâàœ"’ÖP 0|_»Ü(Ê RbÐ/H‰Átø”‹AlÁ¤î¼aõ'Zb¤O–>—-}I“¨+ô¸/Ê’ÔI;綠½ŸÏâNR^[µ0±LWjëc:–gctæÍ–µsã1Û2¾{»»àÜÖ͉Ä0«íQáà³VÎt}k^ßÅšOÞ“a3¾ïÛ%6él ÒØ£ðC'±>þìM¹›äL¤gƒafib·Ý°ééýšRÌS¦¼¦dô–Ú‚«.¨¾,ƒ=_ `L}u`å!Rt!ƒä8+­¦ÏÉ\µ³ÔPÝï‹°Å]n3LÔ$t—¨Æ·e~ÇôÈÃó˜)53s³àé“DüÕ_À†—Öаð$QZëD›ý…­ EÎ œŠœ[ÂßúND«'é¥%Ë„¯Ž–Þ#*±Aö,(lª¶ ßÊ_UýkD%ú׈Š4¿¥–àÎë maaþ¸zÒ0^H,ó€ÎÌŠŽg÷wáM8· —¡æÕÓË#î-]Š¯:uhèþƒéb"•DÙácá챊é¢êºÆ7ú—’ÐÔ‡öXëógP¢gK ¯6Ýï:Ï6”…†ê²;íœÁQwôõ ›ƒÜ¯J|¢KA¢»îò}ÖÑÔ\fÉá$½ÃÁ-Š`ùª¦©öEŸ‚•`æìÞ÷¯ó?º¢¦&‰í'$ü9&6°Ü×Q¶Ûo˜~&÷¹ì EŒçƒé7¿´¡Y2<„ÂGÌl%ѽw¡.¹R÷i/8À•µ4KóÕˆwM¡«´Èw‚ËM™6þ2Ñ&Á€W·ßüm´œú endstream endobj 2714 0 obj << /Type /ObjStm /N 100 /First 1014 /Length 2966 /Filter /FlateDecode >> stream xÚ½[]o\·}ׯàcòP.ÉáÃÂàÄuâÂIËÚ&Fá8Bc4‘R}I}Ïájd+¶VÛøê†Å»Ë;÷ÜápæÌp¶´QC ¥ Y2 ÿUz¨I9° Ò9¡uLî)K…ƒ†TJÈiû„\R;À¨Bd~ᵎZÈ-Ïy=ä^)$ã3Ì“2BòDFפÜ8 w¥Æ(³Hå#,mSÜؾæá?~ÆÛFëõ 9h¶ ¥fŽF1ŽJ ¢eŽr¦¼£” }ðE‚Œ)ÈjjÄR4Ô25PZ¨"ó3è«v¾n±Pu¼P함  šñhY``T‚fU#ˆá3 ÚÔ4+S4<1C%Ðá”bïLôuÜÅ;4…®yŽ0¯ÍEÕzï|•ÐG Šµªó3 ¦6?Á¨ØÒ±Œfs-[6¿ÅrCðüVÂÀšá0ÎQ§EÀ6†êü¶…±}7,÷°©faŒi/ f•Ò}æTæ»÷Œ¡ÌÛ;­·N9+wS7~Ê„Ã#2Uaåи[Œr ‹ ã²<¦9@ƒ¹Ô Æ“K›Ê0î1¾†P÷A7ná­öq/vó4·Û`-„3„RåàÁƒƒÍóß~9›‡''§›£Ëï/æõÓ×'ÿ>Ø|zzöÃñÙ· ž!½Ø|±y²ùìÛzö—GϾ8ú8|òÉþ}8É9*¶é5Í1cùvaxº4ˆÜj4l4i#V:Ž¢‘î ¾#šè{Aœ_~Ž›_ŸžD‰¹-¦¨Fî9É%šÁ$Œ àÈJ‰CÚ*«r­”ã€û+©‚ÕÝÖY¸˜¶‡ ¿¬)ÝÜ€™–ug§Ûk=&¾Šcë*"\ÉJÖY qÖ"ƒ|JTº=¨¥Öü^ O>ûêùÓï>Êù»ÔEÆ®@@t ¥i$ž=p¤Eq”Igr“¨BŸY¸À…ë=¹˜¯ø LAæmA«Ëx ÆR³ƒ°ÒàÝ®.pO÷i xµû´Êø\ýp[pãíI2¢õÕs(`; €6‡g§¯ŽŽ±0asøèqØ<>ûùœ»Êž9÷Û=‹VDx‘=g“G–Tÿÿ,úFz|{}#Ù~+‹þÃé±Ù»é±µýÒã>Ò;é±x‚*ž Š'¨ÕÔê jõ9Õç¨ÏQŸ£žÄª'±êI¬z«ž«?]]²ºäæ’›Kn.¹¹äæ’›Kn.¹¹äæ’›Kî.¹»äî’»Kî.¹»äî’»Kî.¹»dKK&çÎ(\›çŸÛ2gƒ'nÕVÜÚ6fÑ»iÁ_ø;)ð1¸nàÔRöÝÛèèÎ5a£1õÄ_MÐŽÈ•4ï ˆ}Y¦‚̳mk& .…)r£2h¤±’2J˱È,˜$«ód†Ú$Å,rkü¹‚b^¬ -,€är0XÈ Îb·p~‡¥ÛŃ‘*Ö nY‡a—*2õv Íÿê¿Ï~<_ÐLWƒ€[ÆÊnËÈáØ®`'„¯] £_^ž/cä¨é žáén=<9[FUÙ¾½Ã@Ü·q'ŒÃ‹³%HÀ¤Ùr¢6k$4P¶.2Ö;>“Ò¶õ+ÇÚªÝöÁ‘—.‘°¸YÁXÙgQáÌ°I'ƒ5]Ë@3\Å,˜ÑEðä¿Æj wàô x;ƒì²‡«D¾â ÏuXŒ6Ð"K©®Y1%®,å!ócZf‰±Ån;3Šq%’ ª^E®éE€mçÊ,[#©Ùý#3¨X`ö7nÅXhë™až¦qDºlk›÷$…|Û"¶ÌbÜ'=a6Ilö½@^½¾8Ž‡?>úÓÑÓ‡ß|ýÍæ± žS¤- ¬Lí#2¸ÏÙéåñÅŸsY |ßV Œ¥ÌN¢; ¼„à³ËÄò» ÇÚ·Él©bí·ÂNX|°ÇÔ× z^Çzw¶ñ%e¥˜ÀUo«üÞdxçvƒ:àIð.÷m*^¿Ícp¶jð/aþÞRÖ[–roòAG`,,Þ`AgŠuȃTøË>Ú&í£Øíø噘D6E;vÚU6ßbq£, p¼Áaì}´8îÁ(KG ˶àQAmšF*$¨ "»OE–=÷ÞžÚì6Ä'«§" "»Ì–­y³¶ÌÖìÜFl j §n³Óq%½ŸšÿçòåÌe󒉬¤4I˜#/÷î‡dÉB3B,S ý†5݉ä¯_ºdB[c£BB9=¦bÏ‚säÄÓøzÿÏgFP§ß°îÓKiç¹rùÝæ,F[ß³ÆýöD¯Z7ìþº`¿Ù,ßñ'Ö)v{ ˜ð½£ìF‘üV¿MÊ;Õo“ôÇ«ßæ`ó °yؼl^>yøäᓇOד½\<¼\<¼\<®ÊÅ–’²ŠÄÕêƒæƒîóKÎ.9»äì’³KÎ.ÙûáÌûáÌûáÌûáÌûáÌûáÌûáÌûáÌûáÌûáÌûáÌûáÌûáÌûáìªîÅRS)ò'O­³@Ê~˜¼­™#²ÂTV !C£ÂZÛÔ¨2ç¯x¨GYˆ‘p×ÐĶ9›èì2m,p¤¶éK}¤Î¢õ~@­´Te·c¹r}’°6’ZÄ^Ñ–æ Bá ‡ò7bqwáia‚ǃliUrnv0ò«Šm_Ñ@`ù#Å+Þžyƒã<µü endstream endobj 2867 0 obj << /Length 2986 /Filter /FlateDecode >> stream xÚÕZY“Û¸~÷¯ÐKª4•Œƒ8¸)?x7™-§{ã™$•òîGâX¬¥D-g}ºqð–Fš8•äe†@ ýu÷×éâÓ‚.~xAýÿïn_¼¼ŽøÂX©hq{¿`\.ÅBI˜`‹ÛÍâãòÍ÷ïnßþD%þ²«ŸoÿüòZĽ×"I¤V0§¿.v‡¦N««—tYoS÷°Ië´Üeûd_»†â~4"ÛÃ{îq—Ôeö…àZ­¸áÿËkE{‹¯¸ JšÅŠ) ídøq›T錤œ‘˜EAÒo¯V‚Ñe²^§U•nÜÒw#±¶Eå¥Ú4e¶ÿ4꾿²SÔE™ý–ÔY±wÍ”àLœP+‘8Š¼Wv¨ª²»Ü¯ó9ÉØÔ©NRªX§SÉ—×r°”äDËÑRtfNELÏO¹ø¸’RMìzÅ–—˜Ö7{ì ßé±³!c-ú(Eé…ðŸ“Xz”*§Å@]4x³9«©Ÿë”ª …–N'¡ÕÐ؃ZcG;Âk}Ð+eôòöèYå:Š»:ÉöIlEHb«!8ÕU“H£a)lIì”AŸõ#Yo¤ Ò´.ÌNÅ;ãÿ~f†˜Èn˲»Ù)åaD5f” io å3óàJ­¬~€ øª†€ƒ¡‡(j@%C½ÒëY4KfÕõ°MËtF3©Ô©Í1°9¬Ã•ƒ %ÐDä¢DÜ„¸ÑhW”ï~xóîúýh#ÆÃõ?tqAtl›ßÌ. ¥í€y‹ˆnÀW’[<)·"Q·›ûÍŒàLZ ÒõÆ’wp¼Pò˜ÞNÞ .¢§ ‰X»(¸mÁé †öX/Ë4Éñe@…8jäÐí’2«·»´ÎÖsÎgˆŒã‘¡K ˜é™Ú¤z¦hëf!(§¿6 §‹ã…ûOÏKhŒsµ¦™?¦÷I“×½d6Ç$`{ú¹ÌægêÞAU&$âh™¨|LX¿ä@ÖižÔ’òŠÉe²Ãµ1ÙÏ%aM8M’ðÙv㺄ÝbGu8¦‹"ÆÅX—]Rþ2'³`DhÑÛlÕ¹ l¹FO¢ m¸Yo›Òµàçé.µY º,ª\g ¸I+»{؇šTizÙ†0£ˆ˜l‹Ïr[ÓÏ;ß „¢eêÄõ"ÚD ²¹D N7ëÒ\/ÄlèÒ}…y,ÀÅ‘×Ä0/"ãË:o6-Ðu_;×çÈ49Hn=–A‡¸1ôTE‘Ô£ÙFc#ça,ê@‡ÂûtÈÊ<›I"`.%¿v# ~vé(6l L+7ˆÍädäã­õþ03 DÕÆ@6›°E 3tË ù›ª%ßàív;«V±Óð"‡ãnš»*]w]@^> â  b¢µÒÌ×y½-šOÛ+ Òñò!uÿËl ðØàOcÃ%6ûXä~XâÃÀ€8ÅÁŽ}±_¡ŽMǶXKAq(–±Yî›o)ò¼@û=LÏbÖMY¦Þ¥ÛàsV q™=—8$ë_’OéøÐdp(éŽG£3“ŸÀkN”T]… «FBµq0z­"8ârc*C_%¢XxŒS¹Ç¥—È/ð¹oñðbú6 ]f©]xíÎbCëVØš”eòX]èX6‘µ›øáý?n¾}R'EXÌFÕæùë­gÄ3„÷÷ïß>µlD:Δ”C$æá01ù9rº U²^M[ÌŒ±>dŽsîEnrÄn\¥Ú ¢£«_ODµg#þLè„ü%Y<Ø¡;શ€È7/þêï1TÐC#7¾†xûææöÔÎpAtwöÌQŸ\‰wòr£*ÂW”8ËÆPyÇäíi¨8í˜Ò´6¿·¬OÇËêx2<üiZ¶ç:ŸÁb(Ú‚àæŸ9%ƒàÛrŠWÌIã!Ë›po=>«GEv[D®]Õq •ëx:fM%T áÜÚ¥ÙвÅxéˆD5â¯ë"ovg—‡ð÷Ødn`‡:HÕ¿v¡‘‘›‰ÃLçÞépž‚(g1”ý|”;.‡¨‰¡\èƒ4¦}šç€4†hÏ/ij_µä3Ž{U€êÑÉsHKéûáõ™#·e´»Óœ ÌËÐàÂ%ìÃë…QèÚ<Ò°,Ym²äS±g¯S¦h/%“ϵ¥›îŒôB¸F øËôŒ|öRb€‹a¢½¸\*ÐÞ± Gr ©@¸ßµÝ¥(‰Á“e$2ÁCS¥¥ïªüÿ=˜ÂŸFºßîw“f{GÔzsõŒhëéë“hX`F>O `¨ÜtÓÌTËÝ]q5½Qž^$_æ 1Q*>çù$aòF``!¥¿UWãI£P¯ÎœÀ7íUú”Ïöë³ÏÓ²M‰ÃDZ2ŒNø Ïü¨\‘?EQÀãìú»·¼mÒAÚ9ÙÓGÚGÎ%aòè™ãÿú· D¥Ç*Xüþo~á`¿iPbüIƒpö6ÿ¦†<ïB}“×GP}Bî‘O:Ðî-"&°ŸÔ¿Ÿa±R¶ë$‡CY|É ObmD «Oí$=@œÊªVxt…"ïþ²³apF.&'®úòs†ä%Ð6·f{Gz!8ø ÎW—i§gH‚çÝKÒÿÀ…d5ƒ¦“Pú¿½—Íl8ÀÞx2ŸÐ°¡MhØj¿:‚ÆÞ¡þÌZå~àCVo]Ÿ¿P BxIšö¨ý³˜©À“ 9!4òI>°5ý/¿`uÖñ•Þ-E½ GÊ¥»Â~œæR¿.ôŸæiÏTSè£3”íéï(é*ó¾Š>ºŠf¶Ñu–½©UD{Bë×ap r=Þ"÷(wùÛÕ „ƒ+SJ!˜%ùKw³þ¥ËQÉ̲ÈÛçÂÛ\hÃp®íY›ƒ[³;TÓ:›=`PŽ3ª!žÆ—ÕÙÃêÜÙ7“Pä áïfÈ+ƒÇ®¼ÆŸ#hPÉñW7ÉÜl‰¢–ÉÙòŸ EÄýèŸ}Ò$¯Š¹¡XèBûÙ3ÎPçî`e‰>ÂÊäqH±7„ªÇŠg+€H#G5@û5È‘ @ÄÄtecî_b õ1E ÝP%n‹|ÓïÍ.… v¬'.,Þ<·$>Â@¥TâÊÙŸƒç@§dpg5|@ÿ/lv3s endstream endobj 2884 0 obj << /Length 2707 /Filter /FlateDecode >> stream xÚÝZ[“ÓÈ~Ÿ_¡¼ÉÜôUj¥ UɶHQ$©ììƒl·íÈ’‘dØá×çôMVËòeX¨¼XŸîÓ}®ß9-½pôó>rýûõÕãç Ž$Ê’„G×ëˆð‘”D‰ˆ0]¯¢·ñ¿oòVÍ~½þçãç,S‚2Âa&Cõ—ÙœçË¥j[µšÍ©ÀñâÎ^»eon궳w«]STïG¯gfŠ®nŠÏyWÔ•}½Õ+@z {m`î5'É4q˜I×m[,JÇçc^îT;±'‘"œýž†,?dÈ*IÇiÈê‰S ×”¡”¦~Jì†3q”`ðÍ@‘Ùh†`Ù‡3ô«ŽÞÎ…Hâ3*b»k#nHÜzùçNÒa{“7NT]£òÎë3o÷d#ÑŒµ 0ÑPÐFj—õ†J1) câK ªíÚ«ÝF5Å2/m3jÄ&Òõ¹Uͺn6ý¾«ÕÈRÛÝ¢©w0À=*ÊrhÃ…{*Ön{ù¬šzÏWx¾ŽÖIWUËzWuªQ+tÒ1K»÷¿þ¨x?¹›Gàa©vfŒ2`oæ~>#"®K¾«Ú»ÍFu0¯}±Éõ½7ò±Ñ¿7¶ÜŒž\fôÄ=ìéø‚¾Ær0—ù ¸("‰F©¨u¾+»A,œÒ¨DâD( x†R)ñev–ôfF&V•!JÄI;[D:§ÿß{U©Æ›â1¥Ú1!(…®÷½›¯Ô¼^kÙ¯í«…ê>)UÙ‡m£ZÕ|t‘Æ-ˆ tugŸ\¡ Ú(Ñ0†BúîòEQöƒ¤Ò1jîVD*›¼Hz³¼Ï²øEeÿwÞñž(7‚—¥V«„ÿûÜG3ûX¯íÕ«ƒu˜WEµ„Öš°ÚöÊr^8f vc¢ò•#ëj{uì7uã8ÄÜ5`nA0v.8±3O5pÔWµ±|ÉuÔíìv"£ôÀF¸¾í½oUäzþ÷u•—å·ª7E•WníIà}ÅïD0F ï-HK7½«Î¥?>ž^am¯ŸaZ àÁ¡ Í^YÙúí¸›`œÃÒÆ0ÏPBÈÈ2ŠÇ17…Ém×cš-0—þX¬úL{¢¼GÕ°–zc#Ž<ø-=@ç'(D=–†þK½ÿŽý.C’÷I¡hÇ@¬«·Û~UË‚ZÓ}dÔoóÃ@ØØ@¨6 xQðKQFu¢KL²?¼>jër¸üïZA£AãYoÛï0âЀÍ<ü.GÆùß!$¬,H°4Aœö+›ª¿ˆN5ì[(zi*,ê’d€º¤ŽêÄç±`Û#–$Qb€ª¿5úxv}õáJ/ G$¢às˜$gIÆ¢åæêí¯8ZÁŸ› PgÑ'Cº‰H1m3eôæê?¶B·ë§¢ùÊê&é”ãÀTA´‘¸·Nɱšd6ÌÈGæL†47ui‚µ–• <J,olQo!Ç-‹Öz£–a儹R[UÙ¡`€U0ßx<æ" oÆyëMëÍ9ûÇ_•opˆÖ=;®{ ø[òˆcŽ²L~‘îÝT,“P/'¡¢ÎF€ŠEÂ~Üö¢Ovø¹j‚¹7å{1åˆËÞ ^¿xõü_?k®éEL³¯ËTÞ£ @Ž&©"åñKÕMù;ÀÙG½?Y Ème©f¤Õ¥íqn—9ÆSùèõV÷DÚÍ'{XÄ‹|yûÉàŸfeÿRMS7­½ÏÝÕÕ@ÆøaPQQ0ÔZz؛ݢUKך„g†¢£¢,6pZ@qp:`ÈtDó Ü(éik9»¢p5‹Å¨'`'ÒH2ëA#iÌäÞÝ(7TAÐ5Ð>󢄗úY×Fxo‘÷RïåÎ8–é=AÜ·d¬_ûA¦–gâ~&@&:\ø{@ôç nD;ú s ¦I¹=¹_ È“eãR•ž‹=,Eɾ+à©¡ª¸Áeh)â:Uáâì‚cŸ,mõV-=öÍ}ùßcêÚõ&Û²ÖFûÉ>Q'Æj?FÚ$ZBç´9hû<#ǽ’£i{œ®ª–~·úpÔcÿÑŽÓ~Ñ#Ã¤í »iT« ‹‰ A)=¶BmâI¾”Árû‚®õÍ€Òŵöô± ‘¥ã“½ov®’œkþ¦G˜*ãǤ2…ÒQÊ3ÖOÆIk˜‚"ˆA߯Q+õÖQñáòl¿ÜQýÍQˆAp€“ ‚Cù8Á6JÃô{*•Î £HʉÃH{ŽyR¨§ÉÃE:Ê`)•‡Õõ¨žL%JrÒæ(éM†x›¡AÚ\ €{,‰ñtÊÜŸ˜XŽÍÌóp&ª›Â2žÔ1PRöÇèxä± *bÌC?ù?÷Ø@byý6…¾ëþi6OIüjÉWÆ×pá,~9ÅJàt`´Çƒ@èÞ¿Mµötû›CDUÝšlF ÓéM‰á)% hkI©·$È 4žÊ´D€9YŒ™îÛÈœz`CÍq̶©}îÕ™C±ßí¿TÁ»…£&VO¯ÅÓ*u¾ŒÔ<û°s ÙÃ!ÿGSâôDöÀçH³.5 <Ü1leFb¿i߬3€Œf쑆ÅÅ°ƒç¾ƒ˜îî+ÛK½Š;½DîR=(ªð<³ª›Íeø&áˆùšƒ¼?‹9ŠíàïÙŠƒH¼{ 8Ÿ=DÕ‘—>¸?Řˆ±•kB]y¡ïÆŸÇÀ«AyAîû%¸U•>„ZY²û„S”îû‹§Ëˆɧ¤÷×{0OáéQ°u”3ßÆ!`ëÖ!@ :™Øióf_xÑ4ƒÚ'êÊŸ±aÕ¨Í×KpÍíe¬æ@pÕšC NÌ!ZŸ#^ÖU[¬ô÷MöÙs_¨ýdáìÎô‹¡«kRpu{W;Ò¢s\ ö/ër·©¦>Ýñ¤Ýäeyø!ÎEE Á 1Á/+KJhæ&{„CbÓÍÀ©#R~Ñi¯Ãöè6ÂÃѶË;ÿñK 5(0‘lo.Ilz|Б„g¨òï×ïþ’VžAÍhb h}52Ð7º€~·œÛã(ýn³ÓEµ!wT­2/Dßµ®Í7ƒùÄT‰­ÿ7%¶ác¿ Ç 3Þz£/°f™Wyy×zã¼¼ZÇßè³W Í€”&ÞÞS¦›W`tÒhæ½g×Wÿb†· endstream endobj 2929 0 obj << /Length 2779 /Filter /FlateDecode >> stream xÚÍi¯Û¸ñ{~…?Ê@ÌŠ©£èHö(¶È.ÙE²d›¶Õ§ÃÕ‘—ì¯ï g(K²Þ‘æ@>$¤èápf87Ÿ¿:®üÕ?žù³ñåͳ¿ü¤å*i©ÕÍa%ÃH$^E‰2”«›ýê÷·õ7ÿ@˜Š8ˆ‰ð`ŒI‰ÈOÀ_0Bët†!LÄ0¾z³Ñ:òÚ.ëòÝzhß;çë òÞ­ß«»¼:ÒjÞÒXÕM²]€µ—uf/&ˆg4n)´¬62©ˆ”ïS¢™–J„¡þJ\+%-×zÂ5®"×8^1‹Ë—U{ú½;7iL{ª ^'ø¢7ßÕ´¼7o}?¨xOFC[fEApb¦”ìMgš2¯€àh +ªRM‰Õ¬ïêtÖ‘ö®.FN.æqÄÃzú÷o^OA< z «VOQè×7f—+žØÃI™«¼ë÷üYhäÛp ·ÑŽ~6ÕU4ûþ×›Wo}í+øOÒÒ]îðlùˆÖt÷Ý*×Ïôþ.÷M L&" aP"UŠ°ý`Y_°½¾³j¸ ôDèH^¤¾‰€Ï>mC**¦jî%Æöb~ |Þ„Ðצà+BÌY³–pS%júZ± TǾ´œëŠ/`IèUƒG»×HƒÓ En¯µ¼—ƒû8‰µÐA8ç¤ÌšÛ%ŠC)Â8ËX{ùxFÛw’Uþ‚'B$1k "¯hí “‹r°,ãä5‹Æ3óñþ`•„ýw†ö—Æê-¬4æ\d»á0§üsjøü»SÝ2 SäàŒ€øš1óë òMfy¢áha’xçºíÎ5º1øŒay—õ-ÿ†6ha²¦Ë³‚ FžÕþv%%\µæÐw¨8–»Þú–f€Äš¡iyµkL6¥",eÇŸ2bÚ./-ã(•$°7Tš²n>Ð7¹˜ÔgÓ ^ÁsXL}oë p‰Ã @w}³u2EÉgáB“A꼨hò÷4ßÕU×Ôàšøl8fök÷ÌÂu*ðÉzºK;K™{)"5h¸‹q(w°jK{hŠ¼gæðûP78‘^Õ£B}­s¸F7ˉŽæ€@3øyð|D]Aà³8ïN†¹;-aPÝ]HrGdSÜV§™É‰8Q(ç Ö&‘“ÔÏN°ºòA³ª} û¾[¸ƒT(ˆ±òéÑØ’a lE"…Ñnÿ턶p}†Õ 5òd¡DYíLÛ:nµÛÝ:NÀcpÚ÷ÍT?W}iÌXèó°¶;Ðó?àÍ!AOã‡iœøæßÖ \yÛæÛÂŒbâ’³Ö±ð#¹œŠÀ•LL%‚8îÇÓ£ÞÂ]~©*z,…ŠL¡~FaÆΙÀ¤ýPB¨mløÏu€8ûxµNAêÁ ~¿ÿû—™à&¤B¢ãô¢ÌöÌ€£8'ufº–ܺèK†³~’áItj|èDœþéÕ‚ô‘Èࢄ-¡ÍyÄüΩiüÓ4<#Ÿ!1 Áa°¿Hóœ ôfà¶ÙfrÖvvë׌@Þ‘ ºùÃpV®r#²Ñê8ƒèûpi %Ô®:F&Àš¾tmð‰zÍ®^&RC™Î¤|MظJ7vÎß-IR FcI"f 6u¯¬¥c1Â@pCN,`©nöX#  GÌ—:^²!&yy=ã-÷£;m¯`ɪ1Èj.û­ÞE@¹ŠfÕ…µ#¥Xµ0Q‘‡äà¢Õ¥YO`H¾–Z‹(¤Öæ˜xE^µp¥2­´Ð9“ºPè…;˜â݈㞥ÜC‹8Žæ)ý(Q™¸ì0¾N.ýàvÉ_€»ˆ‡Ä †ÐpTŠgYwáû bp1Y88RÀt»}¬ú廥n–|íZýŸ¤M\$cÒH ”SÏM=D÷A}Ø¿aæt_•±¡T”ìËpäJÉh”U‡Ö˜G ˜6ÿøßÞ%Œ€lr³ã ‡² ”rÞ¿0Ô:ª1»"œÍa;¨7× ðÛTSìÑ’Q^Õhâ£Ûë lÖŠ˜¼ê–ìQßÇÑFÅ‚v+`÷RÈJ¶‘ Ýe*¥$>c–˜H!¼ÔšÒÜYÀÙqÔÝ è'Ö׺±Ù'{NY÷Õì ¨­¶üÔ.UB. -­Ey/Š’2ø…Tý«ö~a’W{c/æ;–}Á¿±Å„g@× «¡é{&=So­XóºoñuÀžAÃÁpvjÁ˜^ÀRÎ(M{¾ø”ó‘2º¼cá]Lòò\(A;—¤IJ’qlë’¡.üãËÚ/c˼u: ­@$5š¦Hðˆ.Ïú²8Z"ÍnXà%+ŽLv§Òvtdd`*%_kÖùQ/ %ì°¸¯é›¡ð>·;xOk*z2„R¢²M1‹Ý4]F¯™)R¾Ï/J’z?!?_0žxv¯üÞ‡‹6ˆ,1t©c”O]çÂÄ+rR„¯Ý>Žì;·fËœÁ> stream xÚ½[]o\·}ׯàcòÂ%9Ã! üQ'.œØ ´©ãÇ^B©µä"ù÷=‡»”¥X{µµ©…ã,ï½¼Ãs‡Ã™3C:•¦.¸TZvQ †ÿ)ÅiìªËÚ5gj®ÆÆFt-6’‹¡f¶ÄÅ”ì-…Èl¼áZ{Ë\´XÙ*.–Ùª.ÖÚïAfHìÇcæX]R¶’Kš[¸Ì¹`Œˆ.Öz?.ý)4ëRŠ“ú»ÕIÒþ´9‘BÌ%™jŠNLÙ/%‡‡‰-qÒ"ÇHê4(ŧ •”ÞÏœ áÖ5©r´TæŽ45§¥+HÄi͸'‚wkG Ú:€Ì¡ÆÀÓ¬ìW÷r£^0¹¤.3Pû ¦ ¾ Ög¬jtÖ§¬jr¦ý‹ð1–•ïª:³Ê1ð F• eÎZæWb^K¨ý^u%uÌx­HŸ™\Ñ>3¸,Öu×Jéïn©•o`¢` cä ËÈÔ&!uyÕ¡G—×\µÆ–Á–¨&´¢«Íú½äZ |×ĵͼ™º&…v….­Ï›@W-s4̨kkÄ$£¯¢=4k].ZE(“Ójã×Zƒ½ÆÄ!J@3e~G‰hJã ……߉ Á¬wPšy×pM‡Ö§¬À¨q›#À°"ÌŸ (0ë(Ö;`´¨*F‹&œËŠÑb)£aåĈOvóÌ&ô Cãk­ñcp3…n¡5±Iµ7Æê³WÙÔMo%KDÞ 0•S áèÞ½£ÕË?þ½v«û§§gG«½è×OONÿu´zpöáÝúë¯^¯~X=Y=|ûÅÑêxýö½JV½À’³¨/0%‰Õs‰gÅuËèwßÝ»çV/Üêû³—gnõÈ}óäáO/ŸþòMÊ¿|û­ûî»#ü÷õ@4GŸð¡HÑLi i&ƒW„¶â9—É~ûâö­,áÉ8ÔÜ)|­oô£–}ÀšÖ†ë¢‡"TVá"Tþ>@âT `XˆJññðúÐ ¾À ÀÅ{Ÿão&0œt#õ>¾¹89;õÑË<$±`m€&O/[ò š“ÇrºÈ_Ÿ=˜h¢ & 7: DxÉËÎ?þzŽ—©‹ìcšh!x¸kòŸú“xc¸O¸nr#˜ŸŽx1A2Ou‰ / 7KžNE !ù_5¨&¢,"8þË£¹¤Áqë' ¥yp„[´0DTó‘NF‘Á#œ£±€‹q1šØT/ tà&A¬ãýC: Ppf/š}±N¸|Ì4ÒìÁÁïÞY0Œ°«@Rõ ñí`¢Ï™Á`êÂøJ:+Ê_½m&t¦Ûµ!_nÁº‚UKMÀX‘›. r`aÊ·" ~Üö2w•(|uëL6 ‡YI™ùU„ˆ°¼ZÃT†Ð^™4›"°!QØhbº¬>É"6vTP 5þ"¶Ñ{€b å^´0×B01Ê\=pàT{j @)´% qîÌ@#ÝB¶@TÛÆDö2—„jAP$JIYW€W!=‡;KmÙVËÔ5#àÈa³©‘ŽV0ú5ÐÒrº£¥Â(ã%€‘±-˜Ëvè¾’Yç½ "˜. ©u'û¼F@±ž&ðÞª.VDî»qÓý†øq€§ˆéÖÊåøÌ©™™jüˆEÉÏ͉Ptôb™¿¼9¶¦Îˆ¡é%ÁRɬ[îdn€ZX:õ™nÓ°DXK²åÀ6W#‘©³²˜ ,%"ufù\ÈvXÆÝ( À¸á-e'Pç‡Ñ®Èÿã:q’…²Ýêï?ÿƒ"DUOwúñýû×;;FpöÔ|CZr­÷ã³Ó‹á±À¡ÆíkA“-–í…Í5U¬‘[Ýâ`åÄZZı¡s}V,ã ’_J),©q”ÛKʨs÷…À\B(F’qh,—)7…a!ûšLŒû&,&Ú¡æD‘Qdjc Ù©Ó"Œãg{ñðþÌ:šö-BE¾CëË$0*Åu¾Ù£?|öt*†dÌñXÜÏK$q—Ðõ¤8Øá–ªFóÜC@˜rñìÄÙ¢HkúFÔÃåYÀ0B`˜² #±‘úÀwö„½Ù(žŸü—ìûéÉùÅLß ^00”xÒ¹FØ°yŸÚÍÊxñó3Ý&k˜Ð@ >UþªÔ9¤&*KeÆ30Ø¥Æ Õ† JÍÐKb¶Ùëd½ø‹ì·õH[Y¢~sÙpBºÍôDt³µÏM˜„\‚t9’t!í.<ÈŠçN:·®ó`dã)í±_š'@ž¤Ñ‚0ÏcQˆp<Š’q½ƒ‰ntRî‚÷ªH+ <ºìØÖ¿cÃ0Â6YS¾!¹fÙam9?й…šØ÷ £‘ó¸ã eÎÎ’©Î=Ž“`ö ‡Â‰ ;ØÆäÃ'X¢ÔÁgñ ¢,‚Ö\c:›oOÚgE#³=‹FW;Ž¢‘5eÏÞ‚ØWARöëÅx•Ûz#Ƨ,Á¥hÜU½ºV|ºVʺV£ºR–úS‘+sÆG7a7½©üEB\äëêZU?¯km~Y]ËFý§ŒúOõŸ2ê?eÔʨ,•QY*£²TFe©ŒÊR’ë\ãÔòѨ À#'ÑKWåÓk¿ƒcÀ–$¸ 9¶§Ûîw²çÇ]׌Å>€ÅEÃ)O _˜9ðÀQè}Ò^@êÜšMöMc'T“gfÆ\êÛåÙá%,Û„pjüÆ”ômaž~âñ^ØŠe­`6—˜ÒHûað”¼m3eãQtI 6·<’™3“•g©k‚ úYŠ~Ĺq÷6P#œÛìr_){3?ª¬ ùó¾ÄÁ™Ñ­©ì±¥Vss‘ê÷&a Ü4ž5À ”ø%ܪʞÜêjÇÁhNñx¿ÞäVÖ´_oþòßÀì K×HÑõ¿«<è]ºÆƒ®oö]%RWÒŸv ‘æ2º äÏùÖ—²ª–Úg¬Š™¾˜UÕA‚ê Am 6èUôª zÕ½jƒ^µA¯Z¹ êdˆ@ÔÝ Nq—ÖÔWæ÷ÁÅkŒ%“8çÍÁ:ä6”¹“°#mz{r±öïOÞ­ûmý>ÈüP”yf‹{ÿÛPÄ–¨‡ÜÎKàq}¤Ö‰Õú=Ø ñËŽÃlWêPÿ_8Õ endstream endobj 2936 0 obj << /Length 2664 /Filter /FlateDecode >> stream xÚÍ\]sÛ6}÷¯à£4³Bˆo 3}p8Ó®“fcç¡Óí-Ñ1'åRT\÷×ï @¤MQ&Áé“d‰<À=8÷ „G_£8zŸxýó ÃkáÇI!#Á0’GËÍÙïÄÑ ¾ü%ŠÕ*z¬.ÝD,ˆrï×ÑõÙžh!"A$Š%ïËbLXŒŸnÎÞ\R)s?‹nî"ŒÂŒF‚‚F7«è÷Ùå>_–Ù6OÖYù4_PNÄì¿1/¶yYl×ðÏÿ¸ùåìÝMcV„g#fÕÄPˆ3>‰eDSÀhö!)‹ì¯ù‚ðx–åû²~{·-6‰}o쬌ƒaÌ ñ¨0«èþøübqc )ã.©†øùâãÍ•ÁÊóätðl†'|–dkÔCŒvÁÑ`pkHš‡EX® ÍLSKpE‘¢ªfÿK¾{ÚlR K ža1"Ã*‚öy¦¯Êtª?Óyïj~‡ó‡3h|_Òfð|mUº}0EÙ®'„Ï€BÆç\´gð±Ó=ˆG=!a<¡>"„›Ã(FãñæxgoŽ÷0R‹Ù4.&4ÜHj{Òb³/“#âð <|‡Ä0¼H' ºMÃð¸BV"4®üwGï!œ9O˜€3F¸Ï?—3ïmœù¬(+ÍŠ⇘Æe9’5×K¨õó¯»ù>“¥D5iJj{G¼§Ï§Ä&}Rbø (4°LŠö ~Í×OÍ)ÔïûÂÀx6}·Åtnàý¶ìê?ä¿êWe_·ÅQ#½ßŽ7Ò{HaÖÊaXé`xñ ÆèREÂd ‚AÜÛû]Z˜úeñPlç˜Ï¾g«tu"…ØäD8M ŠLjª²›¼älò©0M#-§Iª ·ÞyYI–§«7Ëíf1_`¡Ùd)““9C!†_›3†’Ðáxá<úœÑäq@Οo£š3ÕF'Ô{l¸9¾kŽ÷Öñæx?‹Z2Q…c®*ÒÝÎm\n‹UZTÚq­žH‡Ø0¼\' „b N®Û„LÕ 1';ªÒœSL@#æ ûg“æ=/€4Ÿ'ƒ’À<É4ABêIü—i0NØxt3Wñìé!µ|gƒSž¬Ÿv™©i)'K›DM™6‡sò2”LÁ«Kœ-^¯Ó?÷i^fn³Ü˜ÿÉzönŸ›LÐïÈ!f;GžÂlr÷›íÚoúQW 1˹šÁ`*ÐÓ¤DŠN³§ÏF˜P·{q¿·l@EúP?Kº”R:]]ª'u°ÁTt8ØtÒ˜CǃÛt¾¢2u`†w˜ Ì`1Ü@É 3ª?ìágÂÈ&)³ÞZ1ÄXï‚"ªtÐnB†ÕN†_ü »øƒ1º£¥äDMi£åcVÞ×KûÉ4î­ôàSðñ¥0ÍGLÀÀ:0b²z¹&‰˜ƒ|­oü´Þ.¿Õl\mM~|¬ÿøœäæ㘓É'å“ÎÁŒtˆV}eÒdõõ-ýSp=}k czúN½#O`£¬j=rê6À ï´€AÙ óNÔÎã¹DTžg&v0säOÓFWP­Geù¡>raP¶ÎÊ,u¹*-Ó47&W®Ö€ªÔÁÙ>|ùð麾¬5J•þlÝ]ã¥Ãœó«Þlª³ˆ‹Çw¨å»§^[KƒЩ@õœ¥T¢4Âw…B€à`Ú‰Vý«+ìÿÒï5Š …`Š„@0^o2@8.àv–>!¹>ÊÅ`ˆ®øÃÀc¤åJñ‹ó«óOsMfçs²þ÷KuDXq ”E „EÄ‹Ñž E!È Q …èÊ‹H™âˆ@cQ?л¼ìÈèZ@“S JeŒdÕö {¤7ž+O·„4@Yô yã!<ã!lx7¸¿1:ß ¼JLƒø €p|Ž‡ð|Ž‡8pz>%O…bÞSõK¨Oá{"âÚ4Û»bê!3•áwS#º‚qíÊ®ºÛq<%"i.›SÚ~ë‰ ácÒ˜¢jÃÖ˜y7 ¶ rg'ŠíÖï¬ÒS‹=±f¨zàâžDÕA‹ g/ZBØ«Z<}ªÅ³Rjm‡r óÊiæ‹å»9Ôì°ôûÂ*#³Ûû©Ùmø+Y:éôy\KiÇõ3ž¯Æ¡ªC Ü¢Œ‡ð\Œ‡p¹ p?Â+r••3…ðáøáùá¹ ªzß ¡«Æ¼ájœuÅ&è“1·®võöªnhÍÃQ¤¥¬Z#%yD‘ŠíÏ|Jßö6~ÈQJG‹ÆUµ¿.Ëm‘ý]Lî ?£ êÎtMƒz3]ø˜>^=³µé]Š›S5ÛX>0_}é`s¨èý%oünD3+0í÷">½}ÿîæóeÕÈÃ<¤…Ù^ðÇ^ ‡ÒÔ!W¬<„i/Wbº9I*½þíC_ú¬¶pý“ur"†›èÜ4±WÀácz7Ç<”^†à|[¿7§•“‡dùÍ ºL$ˆª­øÿE¾™(’yzä'Ç^§CÙèÒ)FŒ…µC~YGC¸ áR6 ~„W¤lP—"8ˆÏÇçxÏçxÇÖæ—|Šv›ßƵ—›Û´hwÉ«‚øë¥ÒVÀðwzž©fË"+3(6Í/Žîb­º*Éë7·v»Ç¬\ÞW>[OFº«0âÙ.M_‹)1¬æˬ‚iw <ܹp·¶xMÖåývÿÕžŽ)ï3¡7Ù×{S2XÁ'·ÑY½ì6‰ßȪ;·$_Ú„µª¤HVUgÝý¸ê‰@ ÑÂ<£qÿ£C’Öžþ‹®œ endstream endobj 2945 0 obj << /Length 3408 /Filter /FlateDecode >> stream xÚÝ\KsãƾëWð’*0eçÁÃUNÕîÆëÈñ+»Êi׈E”I€@k•_Ÿîy !‘0—TfÝ=ýø¦¢Eg3:ûþ†šãÛû›¯ß‹t–4ŠÂÙýjÆDBb*fQ" lv¿œ} îÊùo÷?À]”0ø“³o·¾¿™}ºåQÜÏd›|—I Ì]Zðù Æc<©ù4ØÕy“—­&n×f´ÜoóºXd=¾)¶E›µEU6z¾ZÜÐT›?çLy­'žÖy©g>.²ßü:OyðfÒàÝ?õp1ga¶oò¥a[°ýL)/A XÃì– J8P’ÊTe™— ’J rÖûZŸ.ªín“oõ²à´_¿ißÈ”š¦`Åé§ÿôëGM6ðHÒQ£ “D†ÉP—9àq.ƒ¬^åãüVÄ\/E€Á…ôån5¹&ùL%=áÛ#݉’ØjõÃ/o^> §ˆ°ÐÒ~+@ƒ ©Š6¯Á­s.ƒ¾nu®ìn,ˆ*fåROåu]Õv,Û<7E£'²Ú¬¦(ÑüÀU… N=íÚzPÇC»5Õ]ÈàکÃåiaxpÔfWÕ­  )ÎI ë§0 Ó€€n”o6íºÚ?® óc{àðÐÈNÙ§Œ=ð´³R,ªýÆÐ<6»¼^UõV‚Æ C+¨àùòËæn4h+sTé'»lñ{ö˜£D¨†á&C¬ ˆê ‡ÿ,–Úfiðð<ÎG_¬Ô¦M‰ªW^y¹8¤ÕôÉ6këâ‹›…ËF_<Ì9 ö­¾(«vl©š]$ »( š¢ÝkxA·È0x:X2mš sú«ÌÊáîe¥éPœ:©scC˜Üf¿ÏUž„™ÆàLX„’ .ö­ÊXEñØ®Í%p/V«¼60 çuµ[˜¶/G›=.¯"?’õ’R "º ~óÅ ²<$Q*\âŽ0IIÌKð0‚^’¤NÂLNUàsp0x0o´¾ Îáha–¹H¨pàϽr."È>dó† *•ÙÑ\Uý„v(ÔdÍþ¡iÁÍÖ,²K H AâøW+ƒêÆaÒÆ1œ¬”ˆE[ÕXg.waä!·w-‹fꨤÀË}­}<àSüGÅ!ÀÅáñ»û›?nÂÎŒ—"Àè2 ‰àb¶ØÞ|úΖ0 BDšÌžév&xJ8ãp¾™}¼ù×)’™L"B£ä5&!TFG,„I{°8®?DHI$%°:jÜ0†`º6¢ÑÆ aï ÃèJ…œ“ˆó¡R~A¿ÇJÄ17Œëüïpˆ°(º†x}(†âßU€ÕæX° ªK¿¼?+•ÕŒ ·¾Jwï~¾ÿ!‹QćA>Ž‡ØÿRE|ã*²*Ú¼Tű¤$NNÄpL 9bÑ‘7‹.¼YtîògáÌéÍÂ6°I:´#†'ùÄŸ…ó‰? ç“ ,¬OüY8sJxê½ÆÊè¸yÂÛoÚb·±ûVñ¸no׺‡ëÊåæä®”CÞ¾R?øÇǑž:a ¶rûÛHq8(ýØ+È=]q‡Ï}ÅïÔcyeËŸ.Ø¡îy‚m^*x$Ø$QÖŸ…s? ç„ ,¬9ýY8”Ñd”…(äQÖŸEçoOüY8Ÿx³pæ ~”Û0›ž/x°4¯ì³–{~_/Uç’êÍ!o_QW½ñÕ›sýt‹9$(rI§ vHzž`f—  3’t"’ú³p®ógáœ0…5§? ‡¤ÀâDÉ{’2Ð ;Å'þ,œOüY8ŸL`a}âÏ™“¦D\H#\šß{Ì+ÐÞ[´S/­^A× Uô×¾ò\?\'Ñaë@“Ø:Y®ƒÖóäÚ¸»PîXØqB“iõ?‹ÎoÞ,:ø³pÖôfᕲSeîid S°Ê4dÀÂúd ë“),ŒO&°pæL@›« k˜$J)óCír¿°¥éè{€¯_†ÒKuòÒ¶]Aé!% š{)ðí+o¦[ÖÂíP×Sp;]®…Û3åÚ`¼PîH,Æ(/¼N0ÂÓ[*µê»¬n õÅYÏI«á=ýã¿Ó­Ù`_Ù“8]pg ¶x©à±dês )»‹?‹ÎuÞ,:'ø³pæôfawü¢=|⎠µÜ$Ÿø³p>ñgá|2…õ‰? gN)I(ÅUPV‚VièÞJ-ÜC”ùàèàû—!÷R¼ ·¯m÷ôtæ«©+˜ÍÁé@‘“p:]°ƒÓóÛX»TðH¬Á‘‹I™ëÍÁ9Λƒó€?kJoIáH_ã3p"’ú³èâÍ¢óˆ? çoÎœ‚y%$EÛØÌ|§>–3øi>CL5„Á)×_nCê¥ÊyAj_í®Š•gBêtû9H(rR§ vzž`t—  :.&¥°7ç8oÎþ¬)½98HåòT}{¤²˜Ä!ÕŸ…sˆ? ç‘ ,¬KüY8sÒ„0zâV ÀÍOC*£„†±ÎÌïܧ¸½^…Áç "VÏŽöcaó¡/WŸ÷ÆRD$‹“Ä~ù™RªÉxÒ#“$†ô}ù«çöK—êÐ}#t5/= §{Ãô@‘“=]°èóÛ¾TðXS’$ÓÚŸEç:oüY8sz³p( ,¢$¼¥m0¤ <ÒÍ<˜ÑL$œÄ¶Û«×¾" Âoæ·¡`ÁEÓêüd_ÀÓk×nSlŠVÁN«žE°«švWW‹¼itSÞ¼3½\HŽºS NrÕìè‘Ñ›é÷0!kìa" YÊ{UŸ¢¼_U"Ú^ FRi^˜õ Ƽi‹mfkÊ¡î%À/»õ7ý\Y±1-=Òv¥`íù¼Ýæ¡ }©zS`¹äµW•ßÆų[.ã3ߺ÷&’Ø$É;J@˜Œ#0š Ϫz™ã° ^Ê1åJ)§oÌ5a“ÿ±ÏKý®'Ô/=Š_ƒü|c»v"5§ÛÅð-ÝäùeccÍs]Mœ\öf׸YHÓõ%°‡F}A¾ÁŸUð[Žðت߯+¼8j¥Áy\38/Ǽöè…‹"€tÇeraW=–ÊÓËMùöÇîx„‡ìÖu®O1üðXš©!Ú<ΖÔìk@ƒ8 ƒ·{£H/[ä!k¬xý+Ça Õ¶(‹í~{»ÔÍ”uÞ{¨t ßkÓ¡¨P¢ÎσF¢~rö›IˆiåØŒ ÍуÝÏAÉâ9¬€RØ¿•T7œnr’´ßÇÝYÀˆSÂ…Y»ÆÌ0&\/ófQ*·Â›³Ôp». A“/´H¼Ð9 tuÞîëRßaF7Ár°}Lù©&Xe ýTQ,×ÕÆœåª[7ÊÖx‰SÛìÙ(`V§+\Xzˆ²0©(aÙ9nrê7¹‰ÞÕš’;æ,ÐÎÀ±Fm*ÝÙÜ“g˜{8böJkp©N˜}k ´&ÀPjy u ›-ѽµw+=”Æy¯qÉnxKðøÂ}2yÊc³+ö>[ÿãErØêj0fð‡é]óÙ6ÌY ÝFÝæ½$P¸M™z%&ìµ4°—¦©“X[s¤ž3ÀcõÑ4‡7lœéÒDg|=ãfìFÞá³”Éc8Â&‘È× 5¨ÈÓ£*­÷©„:Ns “Èýxûgœ-œ2×3þáîç÷¿Œ%•þ«ŸT¯¬„'1 ¯°žB.§ç/ÃíT/¬‚‡ð刟p¸r¶i¦çwDNNI™Þª—ü)9a)x!ÆÂœOñ'<‰'‰æD¹¸†?€¤ë¶U;§LÕArW{µÿàЮÎE£r§TëµW#u±ÍKCðIÌoS‘w­Àj++°€Gj•Ô8¼ªì¯*}œÓ~нµŒÀ³ÿÚ @uØa«·ZUˆ,ö=ºÑÿ¨€ÿ¡‹èóþ£Â7£¶ÇÕ+D˜ÂIHÒ0ì9BõßÙšë°Ô‚”•ns»ÕagÊV­ú'¸Sš]þl‰N °‰} Yj²r¿}зÄzŸãgØ« ›ÆowU¡Ãqv§zdõ¿ÉÀ­®Ôã­åÜß\àRW4¡~ÐÉÏ%ì`OÌñßo”ý¢¢—?§M‘TÄ/XŽ¿d¹¶fÖ³œªó´å°Ž;úöL³Ú„H`m¦*½•;¶™šíÙÌÔ…ŠZG5 ôl†—«ªî´ÍRƒÚÚf‰¢¦É·¶¼žÁÄÿÁ. ²ÃW”p)@·„Ù±bqøòî¿ › endstream endobj 2974 0 obj << /Length 3656 /Filter /FlateDecode >> stream xÚµ[Ýoã6Ï_¡—dà¬å·¤}h‹m±íí¶×¤8z}Ply#T¶|’Ý4ýëo†CJ¢,'öfï%¦Èá×p>~3dXô1bÑw7ìÌï×w7o¾•y”%¹1*ºÛD\²DH™L'\òènýÿüî÷?þ‡i¦à_,…fñ’~ú&Á†¶¢-©°kT8våšJÕŽ~ŽfulÛrçèþXp—mW5»dñÛÝ÷ÑR%yÆ£¥‰Rn9ÛãvßaëÍÛ»›ÿÞpØ ‹xĵHxžFÆð$Ë£Õöæ×ßX´†¶ï#–È<‹-å6‰É¡PG·7ÿœãVI–Ñ@@hçÜíßpÊ7ß*1&…"DZ,ò‚ˆ‚ñ„N„H=QÕ-–’«¸ØᯆJÜõDzu m[X‚ûæx "É?ç‘ž~Gm£M‚~JÆï6Ô2#›š:V7U~‘_¾p~¶ä‰ÖÜ÷].yÀÊ©m3`Ö{mƒó)›°˜ÑÑ‘K–'Ìäg¬Á¾mPŠ-'ÐÜ·÷¥+ãxÞÖ¯šíö¸«VÅ$éò­q¥“j¿Þo~|ÿþ¹Ý žèÁÉ›©Ç‡jõ0ñ?þD{)u’¹. Kf¦¬¿œMy^4•6ýÉ¡q±9'€"ÈæSWu_,–JªømzÆcQ«î@ÐU•T"O!¼í XEý¿¯É¦ûbåve¹öãè{óñÁÚúÆu‡,I0À!#«Oå-ËÆ2rÔÖÜ¥ÖëcöÜ6í“«›ÚÜ¡Wõ—wKHçLæ¾lQA½©CVì–+\Poú®.!u’šÞA½ûæÃÝ?¬ô¦äœœ©,Q<ëÕÕBtÉ©´*Ë ÏÞo„X‡²‚ fÌ»3ö-0³.E8wG$r Ö©kêãÁ}ý]Šúè>-mÙí›5vP὘ ´+5 ,Ìïc[Õ5p½›‘T Š%zû„†ƒžÊÖ˜k«²£å:àG+°¿$CTõà…‰¥If‘dz‚ÛÀŽgζœf¿„I*M¤`4©Ô4ý¥Æé/UÖ'ÀÂ1rXŠâ2áÏaÏ¢ÎQÍ„ØZ%©È`(øåÊ%],^_ÀÞË™ ‘0ù “Ïð€Gs}N“€¸êá.eXÓó¢œ7Rec3Àzóf‹#3ÀòA”±­l~:PǘÃé¹³Œ99ÆÒ Çø5,2v"Ì0Ò-µP4AYY> dH¾™×fa†úK„Yg‰N9(¸±ò' 3Œ‘‰Hfi"žâEY6`£!N”Žh.‘e˜ ÓÕsÏp†`,}(ú9ÄêÁúÏ0IÚ¬ƒÈYÄãaYü¶sÃ/'j'Ñn¾Q»²ICnè­ý¯Ý"t´ „Üpù(ó I€úB$f65¤!NÒ 6>sö·0$ó7ÇAÁZ÷s „×ÚhÎÎi“ÈÁ/!CusX,e³VZkî¬4ÛÈÌ«/v /ySÞ'ÕR7n»í&ÝÆ90¬o¨Ú”)?5Ðy¢„>g _Í»³·¬Pó3aú¬‡ƒªÛµ'ñ~½Äë¢]ð x×F¼ì¦þ bö 2ÇônCó\ç%H5– 3 yLÝÍIdCt4V†ŒefÆ–ëªøH—•X»w !€À¦0¡GWÖöÆÊõÛÑ/IˆM Âdì íuÞ £>d*nÿýþ¥{Æá>“¹´µ— 4̪Ùõäýå¡4.Qug/Åè„Ð6íï”ÌdÓÙÕ›FˆÊs~Ŧ ñ%wkrs ðí/ƒ¯\H Î²/ÌåE^8‚]öuìÉâuI¢ž†|´³ÒÞ M.÷,^†È`¯ê£M;aÍô(°”tK%"s|DSÔuYÓWÛØ×AxÌÍÚQuQBÆø„8«â_ý´ÈEüÕB±ø›ªÇÜõ«Ú–öÒ‡&,“©íåÐØi¹ ¢{hŽµq¨?‡ëNð‘áúõ'Ãi~ëŽY†k¥Š‚¾{ÇÊyÆ& lW2ŸP´(ž¡¹<¸ ÂÕ™;70;TßßÖ³ÜÞìÔØXyÈLž¨->m8«¢Â¤3raⶀµÔ…·¸ôQP»KÉ{’ûæ¸['rRðšCéß]Ð)§þ&ÄLð´tO[@àô¨Ý;@úºK‘&if>Éòl Ð*(Cyâdl»øÐ’Ð)ÔàK0 ì½-]EQwÍ•6Nd€wÒñ#¶ïBïv™»u÷o, +žÅ ­¼'ÆXÓ9p5z5âÂ[­ÎÈ!ÞW#ûgxÇžD}ê.-:°k£‡§Ôõ'|¨$?3TºóhfüÜƃ¦}Ó 2ö¨¬«mµ+†‡z÷åª û2ê4É6W]w¼$> ÔgÞù‡™ û%>œhÿ}ŽÅëóØŽ±ÛÉ!:a¦"ù2|´´.? ¥Ê½/x?ˆî×îfÝ…}ÖÂÖ4îɃ „ý»_Íc÷dqHhÑ%¸¢ 9JÝâ»®t.u+½ËÖG`²Å Ô슎âlrÀ'gõ"ÚÑÕöInTr™0‘E\f‰ù'åvq ‘¦`ºòD>?ÆKÉ]Éñ)§}÷ŒÏP_ÎíJ%`NsýÜ3,ÀCHóW%w¥Âû nàr=I>øµk3=ÆDÁ ‡ìßvÙš©˜¸'S’kÐ\ö ù5YÝÍ-Ï5%x®âÎׄFÜÒ  Í`Ä]ÆÌXn3‘¬-Û™ ƒ%¬v×'Ìòágð¤æ%6jtq›W>“ ^õó¦×%ê.¼å6,öœÙ4çm~f‚{nn†·ŽzÖæ+Å=P@jÿÚQ÷K±vd"á‹ÞAêÀDŽªÝ•õôÜ`'j8·gžs㕦A>Ü ÁëâPôS4+kíI¦Sˆ Ùä9ýúØ’mÖþrNgc/<›#ÀðQê˜"¤ã0¢õûw–P¹¹öÑ­P)DœýYýë‡S#¨xAF¹J„×ý¯Eܲ,I•ˆÁ@vÂ_nßþüÒ+_1B¸a+ cP«!Ü(¯ãÀR@ÜÏò Òœc× A&‹€¢æW04*Á";±¼2I ÿKƒ¯uO/Ûî9tÇK@þ0—Ò d™ ˆStÍþó– ‡ endstream endobj 3024 0 obj << /Length 3540 /Filter /FlateDecode >> stream xÚí[[sã¶~÷¯ÐKg¤™‹;ˆæ¡é즛˦];Ó‡$²D¯9•H•¤²q~}ÏÀ (ÒåÉLÛ‹Aàà;ß¹¦‹ ºøúŠNü~u{õê­¤‹„X­åâö~Á%\È…Na‚-n·‹Ÿ–ïÞ¿ýágª(3ð—­~¹ýæÕ[a{oIf ºtâ׫k.Ør}_§e¸Ì×»Ç*«^¯®eË´ª³ýºN·þi•ýžú«,÷¿ß§+¦–Wj¹þê±N+ߊCØg»]Vä¡¥¸÷¿w(äÆÖkæËõnç>­]忲ücøäa½ ߬ ÿ[sœÙâš'„¹¸f”Xeý”ê”6b™÷i™mÖرáËÃú‚áÁ{Won¯þ}…:  ¶à\Î9¨‘ªÄb³¿úéºØÂÃo”H›,>9ÑýB b­€ËÝâæêƒ>¤> % ×Oõâ0X“„>ܲêþ²rng ú’09î'UëëâþzS”+a–éÈ,´ëá‚ŒhúPÆÌЄ›E3nqÃéMAáF}ø(Q‹ÁÝÜ|øzqNl¢¬¾ûëûÛï°Îl·Öñê­â}'D²¤yQ{3PýžióðË1„éömÀ ˆú”ÕL-ȶé=v}ÜÕ¾¡ªK0g+­–ìÈ$Ë[ÿ_î׿eûãÞ ¯ó­2K¡šÅH®œ˜sÀî~Å?ÎJ¡Å› \Êb“VUQVáA™ú‹2­eîìÖÝU‡tSg+Þt´{ôO²|Þ’°D ¡ß|íE,J¤UEá½0óßÞJìégÍsŸ±@"Ñî•è[ׂ"ÀŠ®™»ÖjM¦¨5!ÝYµ ³jÅ—(›º(³ß×50#P,P±Zî GR(œu×È#5ú¶ÝηÂúq€D]ù§°²€=Ç–x{_{/¼MkXq¶zHg.4( ($“¡ Ê1¤“zÖÌØy+c8Q\L,ŒZø½•‘J5+#•îû<ÃÙòMçóPÐû<”ÃÁgýØ°_£Ħ,‡Þr\FlÇ;Gþ ªõjë²\?ú¦w7^Þ£Só ©'ðï`m1'ôXï ¦F<ƒàÄ báW—ù7L >‰‚Rá…ù7!‰áÉB3N„”çú7£aÁí#Ñôa¤}¡Ó§³8ÂLÂT¬ V1†9ŽÛà‚Ë‚‹>„¥2}£ @x±œ¿Aã¯C1¾ëQŒMŠ±½L×»W›bØ90ÿæePFÁ›ÐaÞ;æÝ|œf ¥bÉB‹d©íBY@e#Ù-)p¸ 4ûR$KpÚ \¢e3€Ì¿`#Š€>S/òp³P`¨{¿4yâ÷#ˆ/ði‚‹œ{9ÁÅú®*vÇ:ÜýŠ¯¬wGw«— ŒFŠ|[…× w‡Š˜îm&qjà¤(mÚž9ÑZ¬‰w gdÐ4¯Ë, ÑSž¦Û&dr üÖYx#ßÅvgÙ;(V˜q—ÅÙ´¹K Ü^šfÚ`/Ç‚ ^äÍ=jû>ŽõBd)¸ L"Ï£&{ì’­?ˆh`¹—DŽ|:8¶ª_;m˜/ǘƂw¸qa1Jàð·+øàjCIã >ý&L÷Eùè¯Ó1ÂÚ…‡ž§°—í±Ädz;p>T}NF ÐRÐß­SªàF¹Ù·i¸ Áoǂדcø±øž}¼€È€,ÁòÌSV,wd§`Yák/°b K¢|O˜]Æd£*pL²Kø0Ø»€Þ8ŒQê') \Cø£(„AZ¼@1mŹž˜–gÓ›Ñ,¢7_éÑÛY)mB Éñø@<‘ô³fÛl.ÇlV‚=ÕEíƒ{ÚVPÜeð;¬/`[ºËöYR ”Íý¯_yf» ÔJ¹j—bÉòÝPÈ;ºþ·Öm\`õ È°Í* Ê;ÆÑWž!+vDi»CÝTéLD% ‘§ÅDvV©U6J£CRIKØ0¸‡â¸ ½Kýoˆ±°åÑÿz·å•¡©ð¿ëêtl®ž†p1«àØ„& Œ(²°w7?|7b"£ ¾‚P3ÏB"%0Cù`GÆ„<ÆŒ¸â®šç.FÁ™%šÛ—‚sH¶!y„«Îà`ÉC™9ubÃ6Û§yå=ÞϯC3ײ«>ŽN(Èʼn—L3¶ tp'Ó|ŠŒ`ðTô#œ©+]Íc]K„ˆÊ¬1 M‰ T$—˜ÉF[¦Õ­LI Ï{±ne,kÍ,Ý^ Ñ”ƒ{çtLé%:†\ȶqñwㆠéKæ¦ ì…Ù „wR)à >5ßh÷ÌÕðáQ>ÓZ ÛP-ÞøÛÍ“ÈU€ÜVú’@R«žV§Ç®•ù úT!Íl…ŠNŸ\] Os¡MFŽË#‹¤ üѺö-—C<)ðcõ§4mE›<ëg”?|‡½¨[Íà]V@u7¾žŠpúÆ.ßÍh=úðÊ¿fº×Žyõ¸ß§Ðó&D< —TÆa"Æ”_xDÅør¦÷ÁóózÖºÀ'he»}EX7ê_ŸË7Xo'ân{c~(p¹>¥ÝÚ7Öw:£°ÍúëÖªõ"ž7gK$µ/žòY[©³Y9±cÇÕ´ RÑ|ù—`š2ŽK,‚ Ù™049†7j@(ùÑß 3lý9&»/¶:FGpïB|»ÿ0šÍÈ{Yþ±™ª³i©Œn»Öíøq4 ’ÙÜ9¬é)ÅkÂ;cÀ̳“YâfhHM^cy…WLüK~ÛT¸½QßrzTH„T®«¡¼ã—7µG…úÍîìƒèmªºÍo÷I_áªá:·óÄ™’ßžò;þ¢Ë·ðÎÂDÖ(7¸ÛF¬=º7ι¹—›–ø”DÑa¤"‰Ni¸—ËÐewJÃßÒÀ'sOiÐArØ—ô9¥!ؼS(}&ÈÁ-q*'èeòœ$6B9gÝ!8FGë'ÜÒ)¸ãÛ-s &ï}[6°p`.ê;<(ÂoëÐ0 ¸ %rFŸ*‘ûzK6bíÿ£†^Ô`£¨AH6€Éܨ'¦‡.ÔžåB{§‘€E­/—qÑíÈ÷¢¼íy:jï?ÎD íÕQ."gç"TËÏ3íÛfº¾,jûX·q¤×Ú–¢í&K´2ã€\S§]£_öØÏvë»]zùq8!Ìé¹4û9Î¥j;UNÂÙDøu7JÚ=jÏæEí/šÚdó)ÈlŽ`ÿy *­Ü~ŠC“ä †çÂUH¿À£ ƒQj’4ÅCø Vb0ìè²(÷ý¤0 —Æzowë¶bàS›µ;etqÆ%óî³·ÍÜ&LXdðÖ‡j¬¸‚§ÈÌ‚KFg/)‹ZE8Þ®3¼2DJëè§1ð-ÉM^ÁREáZA¯dT€Á¤¹5Ý~%ÄNhÚ éÅÓ©ëC‘5ö8¬°Ö®Bèéò4¬S!ŸVaB#ê6ãÚŒŸÿÀëRëf«e»¤V‡¤Vé$#=jÝéQ‡´ …ÂìW`8­*qD=U&fB•ëªJ÷wÍÙóËõ¨‡zÿ[zœÉóÏ|? VyNòØèÚç sJRLé˜îñ›ÉßT¶¿ÎewR.ûÅg)›ÿá€iYA&ú§'³ü!w•¢ÿ_p—ÝÏ ñl¥'{ÎŒ=wx¾¯È/áã‰ZŽ¡– Oc5ÙU9ò.Ò”V;|,&šÆa(@¢NΙÓMÀ·M«M™†^iFî(KÌyj™3Ï»À³Û|ŠRžàAI¢SÝ|¼'Ý ÆžO}V R¸$*ÑqÞç}ÀcråïŽ7yÀ;ñþqqïÏ|·)<æ3ð‰ ’ëKº4=ÈKÌ\1ÖÑÿ xu¢DA_¡âtÏIÈ{ŠÞ€ ü?ýÞþ{ endstream endobj 2932 0 obj << /Type /ObjStm /N 100 /First 993 /Length 2565 /Filter /FlateDecode >> stream xÚÅZ]T7}Ÿ_áÇä!nקm E ²Y…€«Ý,áÈh…‚fv‡AÊþûœr·¡g™i®àN¯„ß¾uËÇårÕ)ÛÜ:§’¸uI$5š¸j4,)†'³!S“7Èt)©qIT §$ÜR/ñ†kê&'±DÄ_µÐÜ£Õá·^ð±E‹ f(-œ¨3GKkÑBÿˆzÁg"ã O¬^ÑGôèe¼mz¼Žj|KÀUFoÄIÈB3I` 9¼¥Ã¨ÅL¢…·6z“–ĵÄ8­†.»¢U{ÈQIZ40“ÃF­D«&•è¼C©ªŽÞzR‹‘wK+…¦¤mô†¡jïÑK2âa>MÆ`:ÓH9Ì/iOæ17v·FÑ/m -N^õäˆûRĺ’~N›üòO¬Ò,¬üìÝ›7Ïo„ dF€4ñÜ‘;?!]ÊЋ9Ä„Õ«ÒÎÏ.؈3ZyûÙDi«´{@RPšyaŠ!¢+½à‘Íw È‘°v‘sÚ|@Ú©ó ~UD´x Íã‹óWONaâ´y|ÿAÚ<=ýã2=¿:k_üëôds¸OÏ.ßFÎòø>&çíù»‹W§ã7Ýþöðô·×/îžÿ‘Æ|:°Öôøž† õ²¾ð6x™à»Íφ̆Ά͆ÏF6S3M…4ÒTH[=ÏWZÄY˜=G§ÈÈÌ®œÚ¡µCm͵£¢Ñõ-} u×p¯9Üä)ü“Ñ?¸ ˜ŽaIŒô¾&aÍ¥ë²m¦q[ ê•Mýh0”Òb™î` dP¨£ãx?-†äâ{ÓâŽ{pZÚ­àà’ƒž²Ö b…ˆ‹\s˜¯ë4Ö‡ÏC¥RFø5æ ‚z<Š”¹nâÐjHºv| sf´ƒ ´½™) Ôè0E»õÈ )rÑ.´ø Eú­Ó= .ø[È‹`‰µaj¢ž@P!Tjìx69{~„jö¨tºæ 1t-'¿<\‘ª‚rY0Ä çŒpõ;u<;]o‰Ÿ<ú~õe jZáŸà(ó‘væÉ°X»¨\…1X¥ØB²º/HMZ@.Êc[àÒÒ²ó(«3ØMdõ %½ÂBoæš{÷³¹¦ÚÇ\Se×D¡ÿ¿\3öyvlo’Ešd‘&Y¤Iy ód¢Åÿ@bÉîq´~pjnÅGÎjû@4–´ˆÝ JGpÀWëa²j!”ˆ ƒ%¸£*R‰ýÑã‘ÿˆ«\ûÄ!M±†—À¨«Õ‚˜Ui¢ÐàÝYcÕ $èî8Auì ',`™q¦ƒ_¿]½Û«n±LÕ…,s_0ödi)?Ç â'¤w[¢ÜÃK£6Ô5ˤ)ʯBK¥eËJSû v|ó&oìÞÚÇÛ²Wöu?›7Wý˜7oq|o¶I|m_›Ä×&ñµI|mRj›”Ú&öI…}RaŸš}jö©Ù§fŸš}jö¶&VPFŽ£p‰s°623ÂìØ$í7äŸk×Ó—îÕöLðw/ž™0sîRP¸ë·j¿ù†V +âÐP4—‘t Ĉœb×G•{®XÆK£õ†šPb©lKXkx®‡™Ñºe> stream xÚíZYÛF~Ÿ_¡—$ ê°O’ü’E8ȵñìS’Š¢fS¤BR™L~}ªººÉ&%Æ–íÝÅ1àaÕWuÕWG+Z=¬¢ÕWwÑÂ÷‹û»Ï_©h•°Ôµº?¬¸Œ˜je͸ä«ûýê§õ¯¿{õýW?G:âþòÍ/÷_þJ¦Á8°D&0©°ÝlµëìÐ-­³¼oÚò¬/›úÅf›Jµ~} þþ± BÞOçÞ’PC3§Ø0뱬³º§†';wG•¶øõ\t}±§*nº+ Ü1œ:bþëU‹Ç÷•¿š3a«8K#¾Úòˆ¥:¥3½þçw÷ßàtRz |œ1C%LñHýÙf«}ÉÈ­’)¹î³²î°–Ð9±ÐYE§¬í© ™¥!3Øf›Äz}ïÇOø„ Çìw Ç£ýMŽç6±ÙJ ç¾å1{€ ÚgªÒ>l‡#ȳ® î̶ÀýUņëõïn®¶ìE_æTÿ "a\qÏÒ€ï¼ -YœN.e¸Y¿ögéÜ vȬí¯D²N˜uãÈ/5ìQª÷Ò»ÔdÒqÈTÕEª˜æ1ܯb©RËŒùðn<©Ô%#·¤a<¬Ùsb!D¨:´’Å–rŠzZ:Ô›u¹Y»eЃ kÓQùC¡þzΣ”E©ü[Ñÿ׊.µaZ$‹Š®–]³8V¢ yEÇâ5E©!‰D‚¾éÑc±>w~ µ8ÉÖÛSS¢ÔÚÞSÑÚÙ:ªã ìâUECOm“]×´»&ÜNÓ’¼K¨øBÞ鲊ªD!б·GSQåiP‹]Õäo©XÑýR¥Íê·£F|ñÍ£œÎuŽófUÙ;‘)ݼÀ¥'ù ÿdY×oölÀæ.c²WÛÒgìÑØ™µî¸uÓSáÜy/ë™üæç¶-jG÷:0EÛÁ9˜ƒ–&B2¥bïO\î¾¼¿ûõ½“hÅW\ ÆÓ‡3ßüx÷Ó/Ñj_ƒHP®'Kz\ fPŠ«Õ›»‘3>=®Kš)‚avU€Å˜*ÒBqT ËŽ+Â,9SƒÓa¯Eëí Kzë¸=ˆBGÛfÏT$i5ë}y,êŽÄ†¨ðWFÂ:SØ?B;Öˆ¹@wh*'?¥Ð÷P5;Ò +ƒØ½8âr5q=NYË%!&/o*?¢ [%ö„ê¯S«¿ý÷·?¼¹ÂaX’L|ñ^¸þ¡1|*«£¨.€ŠÒàtèÉEÄfѧ<ЗÇë*ëzjÊI÷±³¹rÊØ0¥ï88kwÎç ¸Häº&‰Ø ¾:ÝE~O7j¾EÛ6-›ÜêÓžð~NÉê';ôM‘»Ë„J2¹ƒÁ¹°ÂÁ%¸nFL¥ÃnÀš£®œíµþàÁ={[öÝ#U[ôç¶^¨¹\ƒ«–Eb  Mµ÷(¹ß— ©Bå@‚]sîgèåYòßÎú‚S:0Óä[Æ&{G âV 8w(s×¼+ú§ÂÚ“þ²H’Õû±û¢×ò:ûǬ§–+³@?iÐïŽËܲšI"¼õƒ†Ñú!᪽=]4ˆG+ÛZ{~g~ªsAíÚ ùrÓA§¬ÇU©ýé±Ì©Çˌ뀨w¶î±±j MKZu[Lœ&€iIùÈYrž$`ê ý/‡¼¯p#ƒ >„Ig>3¡n†Q>:ùZY¥’R¬±Ò®y°( $˜M·èéŠ:ÄÌ🉕MKœÄÒäˆ/oãV"™Pñ·Å#ÁÁW=o{L”îÛ.ˆ3©Òùý¼Óí—À = {É#øç¶@ñ ²ÂjhkgüwG$Ñfz}OeU…ç ÂIk43]/o v`%)ß›Ëj˜oæ/׌'éEøðN+É"yÉ` ­õ>`ÈM»1šIñÚ8½íÛÖÔ,ÒqÀí¿ZD™|Jfˆ0_A†É®!ƒbF˜c=ƒŽ\ì,³™Ç—ËY¦“HÏÈ!ÒÃì˜äç®ì^ ºéõý&cK±Zç|$ÒAÒnžÊÑ]m@^t}yÌlI0óûù$‘*|Ö§ißv§ÌÚd ´A8|;ˆ>Áh>eÉ”¾ùIŃpëb ˶%ló( ¥§°yÁB!™‡”çÍv]Sû‚š‹y¾`wjjôqì0罚 ^ÓpÕG@*_ cFºÆmÙæËùzÂ8âGj˜˜ã ømYàv¸pa!–£’G ×ôè Öñ ëTë`è@³:ÊS•ÕÝtˆïÑ­£F›o‡/øuÛæ°Í‡µ/’ ×<œÛ“R‚ÙCžOˆÛò|/¹Ïô=ˆ„DßÚ^Gs~x¤o¸+áÔà¯ÌIô9lÛ—Ý[*9AÇþÒ‰Ûî¹/œáŽ$ÅÞBë\»°-Ï\4 a´ŠÔ”y;|-áaök˜ìRpK“ vÌ@ĶÙÜLKå²ïhä¨ØèVÝ´å|97¡“üqêk…ïHZ®“Ï®ÉAb½ ¤ŒÖÜà—¯¾¡ƒcT•Om‘—È»Aûæ¼[êÇñð}ÇõZ›‰ÃÂ)¦Ï@2 žº«›G|(òkªç È(à†éY+UëÂ…&ù4ºS©žp(1Àïè˜#QYßhø’ »¹p3Òw*K ./©6¶;Ú.âHCt°Ûˆhq4uõLÛEûÊÓR †0 bß8üZ|‚ðU-ËÔı”"öÆRÚ¤Ò`,X¨ÀX"á`,‘tj,í`k_ƒÝÞïåÑ:˜mŸÇìÊ?Š¥|§ÕÐÞÕú¶(ÞOZhŸ×Ïf>ÉÙ¾óYrí²ä6ƒ»/ºÿâI⥓pŠ½žýl1ûÔ¡¶7í¾h­±NWÑ?6{7"ïÏ ïÏTCOĺbz;â×…k%\<‡NÖ¾8µ#òùSln®º‚&Ï'[RdlÜî©Õ¹(Å­@Á`k1€q‡oŽu_ZuN5Y‘µp”µ~ØK¿L™ˆÅ壸íQÈ=ôÇJ­¨ ú™‚µ{UxüæÆGR–À¤K¯¤ñ;÷‡ÔÇÄ_Q’\úlï4C欗u€Åë£EAA¿ ÉÊ u _RS#éF¹µ£¬ÜvTÉÐ`‘4–èxgÖøcOéf ÅÄŽ Cƒ‰˜%–Fá 1Áç*–¼ƒÆãd³ÌøV‚ •Ž •ò hAÏ›¾=ƒ&·ö¬PïžÀ-|ËFbËh•Êé‘)¥§3EDá¦qÃÊ«ˆÛ'h¶½àÉ-P`˹HýläGz–GMœ¯\öqçtïBÐD’ûC™ÈX’-'ò²Þ—yfÝn¤sÙÛpÂ.<:ÖÇ£'ÁìsBãÓ¯¬ùB—EMž]ñwÅõ­N‡Iý¡«¬O>ANÇš&÷½)ªâ—áóìˆuìB›>H¦Òeë‘šP¦”œ&ü…Öµ·d“LR 8bðžìOÂ&Þ“°ª¨kî=açen)g>b Š]ä0Q>8b‘ÐW¬‰ŠåÄcR± £ãvÑ1’-'´H]‰Ã‡yƒ@ j¡‹T“ÄöÛ]ÇÒWÎÂ&rüg9)ð )~œÃÖ“^h—Ž£+lÕ&“ HBI,á&±Ûù¢¶éÑF6"ç¸}M©©‹$úU3×3É ÁÿGÞ@Hÿ:"Åð3 éSXò¹.)œQá>€MÚ¤çø9ŠDå{Ÿ âì‹a5RN†‰ªç™§ts ËÔ‹ìœpÙa’à¶ô­bfLÉÞYæ˜ÐÓ±éÜŠM?`aÔÁ§/^ã†múëþ œ¨'釰ÓB›hBº¯XûÕ1á€_ò2`&›8“iÊÌ >ÂTƒÒô›”iŸOCŒ>¿OCLR÷áÓ$ªž¥!þÓ®–~SîO4ñ-Œ3Íæª@’r6aÊÙ\¤œO9‡Qô†û_t™YäŒ fã2ÌÆC•m²Ú ß=²d~¿£øxnòen³]^e&4}®í4ʬ²vÃ`Hס´w¼‹t¡™)Zuc½t³Ts«%Ó'b3òåýÝŸHÍñÔ endstream endobj 3104 0 obj << /Length 3356 /Filter /FlateDecode >> stream xÚÝ[Ý㶿¿Â/l fø)’Aó¹àšä’f7(Š\´¶vW¨-m%9›Í_ß’ú–|–ï}¸35"©™áð7äÒÕÊ®¾~Eg~ÿvûêÓ×’® ±Q$W·÷+&(áB®"£lu»_ý¼~óöõ÷_¿£Š2ÿ³Í/·ÿôµ°aŠ‘H˜Óõßn¶"¢ëø¾J ß¼ß0xÞUy‘þWiž}¶Ù*ÁÖ·C×y|·ìt¼«‡ä÷Í/Wëûí>ò¬îù”"õ× Çᥧ¥÷ÈG ƒjU ”õÃ_eåœc¢šë›}Æ{å Dd(ÄÖ?§»Àm5%CæaÊÕ–kN´ˆV[F‰UÖÏ‘%¦Öµ•xqà9Ùl%µ#%(— Hð;Ø#.Òêñ˜TéÎ-Šë±T¸Ü6ש€y>PømN6[mÌúÍB¤&0¬žõÍ—oo¿u¶&j[›cG"™é®²ƒc«ÇÄó´O¼åUPô¨Ó P·¿í§}R†…’‚jú 526­ï‹üˆ-µvCÒS\ćCrðOEžW¾•åûУڰ5,`•ìýóÝ‹ÿ½ÙÅß~ñÃÆòõI×_~C<e¹uÜâÓF'qžªÇ¸ª[aúSéìZ%t}ÌO‡ð2©–­ í+`Á¢(&ëE©òÍ–±ŽýÏS^¦}SGê¯H«fëSò @ eü‚ïøš9sF†}AÄÞŒeš=é©ÈwIYÖ]ÓÌO‘û$jv@žðÆzK„òcÂv&$ê)Á‰O‚W~GàÛÙ Ž†F…Š*ü{XßÌScO8ä8à9 “ßå§lO¼UGZ¯_Ÿ |Ì §Äˆ¯Ÿ“l!"Úˆh9ÚŠ\^°êZªz`6“€­-ê«®tº×Ê/ü2ÿgû…¸! çújèÂoº…‚_þɲO F˜iõ4vgôdL·=øñ:qöìt8¼—'˜Z«u„SGŒP­W‚4Íø9V FÝéÞ7H´!xÓšmæ9KïVÓ ¾2}¨_9–áå]#²µ~“¼eœÈ…äõ& ëgDoØÀŽ¶ÂÀû{Ò.βº}—„_˜É·œ:ý `fž4½9‰ã ñ“ˆFž£·y¦ô¨‹­¥® 5×{Züd´²Ø\)èØ^g®Q=§µkýRÿs_óµËOoÔžP¾!@)Ò<ÆØNJÒûfûíÓ[¦4á]1ltŇ̋¹P”‚·P”3V‡¢Ø¬CÑ :•6E'Ó‰F±gÈqæ£Q¤í“Cü‚îú;†à$<¸{çZ‘ÆwÎ=u¦ð{œ¹Ï?¤Yý5§œß|×#¸? hÞßNûVvX‡²³Q 7%«ô耚wIõœ¸-ŒO;t”}—tˆi²ªÜ.ÖVJŽÖω‘…Ûð°‹Kt6‚ÂΤx·ÇT…ÏzÓ˜à¯Þd¹yÀmŒUQ ŽàYc¤fÀ{JrÃH4t‚þ©Ž’̚ѿx’K,Ü«0:“ïüªx/‹/ÒlŸî €+ý#|8-M ñ,þÑqoíú&©*ˆVp¤¶Bh¨s…Hl§sä§" 1 Œó=Pº…>jÀx=rêÑ{Ãk¬ƒB'\òÑ7ÍEß4W~|¡ˆÆy_–GÔ½aó”ÈA*pL«Ú¸ýÔÁÃc¾OßQÊ“àb0¼=}ÃèJ­/ÀÒÿÄÿä<þµ˜½ N/ÀŸšÎĺاÚ$Ö¹û ^ûꥅú óR0÷\Í@¹ºN”2?œ:¼`¹¬’§²OJaü(‡Ð;Á•Ë’c’UËE­N4_(±«e 1ï0)Àì&ܵ¾hN,¾XÕ_° >æ¥LËÏEéú«üBÀ‹ÁÛï‰oáG0iÂöœ=¨Ö?8T„ß»¾€…rìCÕQuö²mžï~ú æ·‚GDEº¿ÍÒ ¸ÏjcÜÇU<5ŠS–9Pœ´i·~_ݾúÏ+T ]±7°L~A2C”V»ã«Ÿ¡«=¼Ü&ÒšÕ³ëz„$ˆ(WË:¬n^ýc0‡|%-xe«ÎÍá¡X˜Â•Ù¢žrL±MSI¤ÕBow ŸÐ`“#D™+>>ÖNÁä8zˆìÁúÊÂNÄs³ýóÌú6íVxùü‹:;Ì­€PG8…gô=æe5…dYy:6¶ÔF8=ÈóÖK®GÄ®‚ S!t XGâ ·°Pa¯Mâ°9RKýÐ’Äh5-{nθ3Õ†éjÒOaeèÆÁöpõÖ@UéŸ|”°ªOšÆ)fÑŠ½§¸!†7üvð &vøäCj –á»ùήC³S1\g-Î*ÙÇÚ?æÿkÿر€C"ÑWqHþ1÷iŸ´Î†œnÀb&äIÏI‘,¬ÂSðàºq•ÿüfÂEаø»9ÄnÑÅnÙ>r÷ýr$ÜÉΤa&÷ÉŸn¾úñœÞ¹$ßúž´çT›î“}HƒBdk"!@€t·Þ.’èéO†Òu/elÞáî9„å‘ E6⢈_Ê…ù‰t.ðŒÆ™E2µ–ÊÕhœE@70 Qj\õŽQySí»”4lÔ!÷ë]H¾Ì_hã¼ü´¿àtÛ9¡¬‚­ÕØ.)í¤ŒwR|[§8¡!(/RÄsì€ò"ÑŸòPÖAQ̵uÄñ ÊÏ5ÄÖß¹T"©Ó>Bõ ÞßFi4¨¿€äç)Ïö¥'@ïÔÐ ò †šKlÜÔX_B5åd'3ÌÙÊl´—Ù„Â6ú23XŒT¾Õä¸SÖ)Ê9Y\ Çï.¦ˆQvpöÓ_îÏî £GaXV Ñß =Ò ¾ÊQØ| ‡%ªž¬}2Ø ]† ›ƒAòÝúû¿.“ÚIí•BÛVè‹":HŸüÉòTÊÙ|ÎØaq&¤Ã‚Š‰ÁùEsb*d“‡ 1ÒI­CH‡]ö =Û©.Ïj麤ÚË -ñgqÉ®»Ó¡Š.Ö°iƒÓùSÅdaµþ,1™úPqøÿ,&ó‡â\F`2ÍùY}äF@œ3 ×1Ø€ ùD}œŽw8Z8‡ú÷U¡†0Dš³Ñ°‘Ëع1D¿½>ÖÖ’Hú™„àÆŒ(Þ]ƒ^ .|„Ûè*\pÄÚ?2.ãZ¥ùGˆËp&¡ÅqY\$Í6‘ð‘նłŠèmE´XMÇÂK|#k®88P„7Ãæ7Ÿ¯‡_¨.f4€€™Ó—üëká1ëÇR˜…`‚Ížò3%w¥ºù¸°Æ„™>> ²=/€î®Þ¿`0ÿâGŽî»š59Ý·w¸}\ ô²>v¾Ýîo¤ø3µ|{ƺÎóuké³Å|®Æ0×ÍénRÚö&¥íš¬’¦Ẇ·¡˜Ù¶˜íN8¥ë‹•¶WÍlCž¯æk{a1?š+æ+nB1_që3}$5Å|G½ ˜×”"~KÒÈs…l‰nILó­†ý¡WœF„­§£4ÚÌWó­A§À)ÆýÁzòSµÍïÏô%ØdɢP…ÄšŠ˜¨èlKpá=)®8n&ÖŒaùö"Ïþ!lR²þÄú:Ì„å1F,m¾ë³:g[ÁÈì:öÏiïF¾éÀ>öX û[±à›&¯LÊEðßÔkš£®&Öï\f­O7 Øú®Âñ²‰ÞÚKö_øøøåÿ¶ ¶ÿÃ*ÃüCOV>ü`…Ÿ9X1­s@o«yãm¡9émUÇÛBç35¯¯¸Akä=–d¾dX`ün@­o’Ä¿ª U=áwó0y¸ÈÁöÜñxZ²»šdùÄ­Øö–^{é®ÇÑG¸üÀÏœ*™ˆÏ)TÌ(t&E¬õ:ÔµhKsHt™’­®:¥9O@–½ÍA·ÍÁkosºs¹l*´Aσ’XÞLÍ•7±/X¸ ‚ýüu&<«+î©|øØ«j &§«šÌxAYCÞ-k ‡ºAw"œáõì—5D–¾ªé;¹»\~X¸=j  ¯Ÿ‹Ú~© õu5.‡¦ôùÒ?›`ðÝq…Ï..kJüƒ‰Ì³×0>Ïö|YsB¨àC»ÈÊ4ž4±ö®— ÐZ3S#^¬€n×~šOý±åDŸÏò™¦„ºœ¼Ú´W£3Xò}[û9ÚuÔБ2w‡šH±åÄ°9)IH(??æe]u‹ OûðXÏ”GüûÆmÇÃb]•ÃÛ8Û5þÜ_9jo‹]°-³ ¢NÕz>Œ– €"Û“ú94†!VG~Õ1Àe K ì77Rëáêý½ÿå endstream endobj 3037 0 obj << /Type /ObjStm /N 100 /First 996 /Length 2416 /Filter /FlateDecode >> stream xÚ½ZÑŽ\· }߯ÐcòH‘”Ž8®áuѦŽgZ1vŠÝ5þ}5£Y7]ß½N´^ݹuDQyt¹µRàÖ$P&oh`«Þ° ©¿*A³z£³â*^å„ÿZî ”,{‹Qkghe¨Ìâ¿A¹Xó–²dÞ²@Ez¨–þÆMÔõµÀ$-<2W×B€'LÞâÀªcPÚÖßJàÚ±cµÞJ)ù¬!s®ÜðÇÂhe‘¹¿Å !ïË-˃ñ›µä-õ>%Ç£eëH3£ÕØ[²dW±ÒÁ»öð`ʼŸnÆÙ‡@¯«çT8uÅ@!â"‰j-> jA ù[NAªôiPV€pPb vU6—Áâõå ª]ŸXPëú€[kòq¥mÒ{´`©xKS0î‹¥,;ð¤0[Ÿ‡fxCê¿I€:Á°Õ¾Ðj¡¤ýÛ uÍZCáâHµ…"ä,…¢êú·XõEB©˜—jì-ôm©ž1ÃËJSï[­æ£ÁœÕ'ˆVA«ùhèQ)ûhXíJÕ{Ô*c=IàÔ•‹÷¨jînU-+˜„«ãsw¯¢}ˆ©OȪù:Ymê( su&¡ñ~jŠÍ±Ÿš…&}‰ ¯»©°Ú­ôiÀ^­6—ƒJÝóRÅö€'{t$8¡¯k…cq»,f+ûàèK©t?o¾k_)x"¥fvöàÁÙæåþ½ ›o..v×g›ó?_÷ç§ï.~=Û|»»üe{ù*!¤×›'›ï7_Q8ۼؾ½¯¨¤è&Ò”"c³p*±º³á±(ľ „ÍyØ|·{¹ ›Gá‹¿ýú׫íå—áë¯ÏðïÏCà,Q±^R$L !!6 › b©nÅðýÃg/ŸþôÓO_΂=IcÏYŽÕ7zÍ‘+ߎãj÷þéîí< BÝ+´£´e Ïÿ¦È3M!&‘Ø MÍá,à8Ÿl rÀ.åX8˜J4D1Žó­žÎ^Î)úx¡9*bÀˆg/žœODPS4³»(5ŸÖ 8!àõ@ùi°â>üÒÓç!’4*ŽV‹†P+„çB 8ænìR~ÀÅv)'‡Ì ÃâD‰žP³¨ˆœNŠì“0¾Ž4uYˆcòôä„áâyÑ 4Û?ªŸß%"¥‚{”(È»2BGÖ…eiS½ƒ92é…a³”£@ŒHÅž0ÇŒü1×¾U=+‰¹ÑÒšðT Ä-öà8˨4Äqüe<·z+$2H­±WC œq¶zÙ²H>,z2€ˆ¶KYrÈxhîv!d8ž„{ƒApÚ{5Bc–Ûép i1ö‡ ë “Å…™ëª-EAvÀ᧠÷ú÷ns ‚B‹ ‚ã¶!ž.¹WÁø„jh8ÌÄI?Æ#¤ÄNH¼›¿ÿøТ*IÔÞ¿ýIA”M]ÒšÆÔòZiäÍž§­”FzãuüJiDЂˆºNZ N];KõD Õô:iÅèJi÷èZ›Hòô{¥pƎͼZZräºÖ€Œ•Q¯”N5fÄÒuÒTa’¼ )âbûîÇ»‹ë¾ KBÈûn3Â:ÑáÁRÐ:Þ8ÏBe<àMbðÏVöât‘ôŒ´y~¹{{¾Å– ›ç‡ÍËío×áõÿîòçoþµ=Û< íÅõ•ç}¾™¯v.ßn¯ölGÿí‡í/ïÞ|»û-ôý﬊oléço.Ñiƒ{ì¸ÂÀ¸r<·:4Ú¡Ái4èÐ<2:6C³ Í24ëЬC³Í:4ëЬC³Í:4ëЬC³ Ͷ×üznZn…pªÝ¤ågãš—ÂfžZdTЙÌɼÈØË~ªP*æ¤ÏçÙÜJ¥aÇcIpªQÁÉÚ¢¯¹‡élºŒ„§žhJQ‘j $=Iç¶ÉäÕQDª›+Ž•e›Œ¢I4gè#Íx6>¿2â+£PB0ŠâdØyj9È fpÀà8æ†rßåˆi 2ív'ŽÉ~éô##q=Â@Ï4–×c"¸} Ö("+ìÀs4¸ßÀ…_6¢Jò$[P[¤5x®[Àþê7¾†¢fÈfð»dœüµ-ºç\*°*–YWA5ßÜ/öE&’ÑÈËgßG¢áô0ÃÀýš½D®‹7}e.KŒ³Kò2SØCÖà˜Lî•Ìy¿G¥bq™å™ë§Œú¶ê¡¾u{üÃï¦á·Vé3ü´—Σ„½“æùXðnšçViš[Ë÷[…‘NúÝê:iEæÕn%@n•&üMk‘ˆxª¿v’áˆce­4·XYÖJ#ÑM²7#¢¦V×J«—kq;Õˆl¥4IŽ¶Z7Q‹Îp|6qó ó;zæ#JçÒ3”äÿèJüÇ鼈 ^Ä/bƒ±Á‹ØàElð"6x‘:„ë®C¸á:„Û QÚ gڀь6`´¡¹ ÍmhnCs;hÆâÆÐ\ÒLžFÇ‚pkÙšg-Hã[ÊA8ä9üøÃĸ[J$ç"Df‘'š:~Ô×vCTeœÇâDÀÝDÝËEö BŽ Är@D86lxË8W!¡¶Šþ!¡Ÿ3ò‰*wÉ2ý& ±Àõ?v„ÓÚê  ?¦zßÄñW|æRyr¶jÀýP1ð ÿxpÁ²ô[Œ% Oþ¹Û]c¸m$žyÜ:õaÉ?Š’þ­\®NùGQùk¢=O;¨ÙlÀý¬‰æØü3A$ÎÅ¿œDšçì*Ù¢‹Ã¦âÀ¸Hâ8PkFn«p̽ÐGx`lŽ#äIþåð “ÙméW@õŠ•ŸñÒ·6;É÷œã“Ò\ ¼²ŽOJsC>Ëi l+ü"+Åâ× çê4™‘R¸XñÞ,Çl‚6ž endstream endobj 3168 0 obj << /Length 3791 /Filter /FlateDecode >> stream xÚ½[Ksã6¾Ï¯Ðe«äª‚7É©šC²5“rj3Éf¼—Íä@S”ÍŠD*$•‰óë· ð¥‡M¹j6»ýøºñÅÂ/¾ÃÏ\¿»{óÍGÍ1K¬Õ‹»ÍB(Î¤Ò &”XÜ­¿.o?}üéû/ÜpÅῸùíî‡o>ªdðšLrsºçÓrMÏŒ§6,‚ùtNñ¢9W7+%ø2Ý´yM±lªí¡-ªòÝÍJ+±ü\üÓ3EIìŠíî74Zmhôþ©Í'C»|WÕO4–on¤Ynò¬-°ñç0Ë|ûDšÜq¶X Ôá…%&! ׇº(nVÒðŽ6êíÓ&‡/v’ÿ棑^Ƶ€é4K´¦é¾pM^‰'a&N‚t¾HÁŸ,’ûò;bj—þEý Ù!žjI·[Od]eyÓTus‰Ð}v%$0._K©8¢´9쮥´ÿúHíVÊ0c#/\5Õ>y^û`Ú'“$hŸk–éö©)Ô>ž,ïsoŸö¾…Ú5|Ò÷²öœôXdÔÌÀfŠHFÌÚ#¯=+!ËŒéÞ«óöP—žèö1'‚¼‘x"ͤ°cñTõ:'Ç %(Şܶћ «‘v"À¡uþ…sY‚—qÝû§yÌ 3ÇG ñ<·ŠqÕ)èB¬Oè’ôH,;v%]pÙñºOkÐò|K½nÑÉwÆ‚)ÅÔi‚Ž“‘&Mš€ã^t_¡ BBhãú Uˆ˜–âH § H΀_¬yÜ­32®3¼=wW‚VK3aoÿÉ<ûg/ò£Ö0eÌ8Hõ*¢ÎøQ÷¥N³Ð˃·<dÁê‘Za×E\×…˜'¤D0~j ñ‹la —n[¢Â¹q¸6¹¸¯ÚGj…à ½Z¸±Þ÷»Þzrã´>k«ºø;už,dm≅8Ñ8?-–·›yÂÇËäJatï½"ŒVÑÒ!¸‚÷«Ÿ¨ÙVþJ‘0ŽÈóžDG*ãWÁÆpù¡{ô=Ô”¿Š–¾°©«]ÿQ'9p-±Ç‚ „¼E™+|gÓrYVtm²tKÐMBv²j·?´¤‚²GxZ†%£%–a‰»û0rh«¬mæçȳ¢!dˆ+¨iªÒa»'Vø]Rˆ¢ž hý¹ :rwPÂ$­,ß·4†Î¯D[dѺjÚUë]RÞÌtª‰fZÙ+ 4\†×œîdU@Xêû{’•Q?DO×öW`ré´B°J@f“ì¦àH|CãÈì½Ä Ëó‚ú¥^ÐhŠ•*òdaƒ´Í/¢²!GO¬sð1»¢LË–žèÜ­4N]±{¤”¢9ZÐÞÁ¿S"¸øxB<€Ê¹0‰`YU¶iAÁU…઼ÕïÁmAÁèX÷ Rp2Ÿs/Ý6Õ\\­  ÀË/B>'CÞ†„ÍäÎD¬ÇÔ³¤ŠìuöóvÞg*%öõB¥hÕ‹Ä"æÅ.ºwEeÄƾÂ(ö5Ÿ XÀI5AuÇÖóT÷Ž3}J¾¢KwO ií]iYµÔðHÍPýeän³C];ÓÅŽÏé12_%’  Ei+€¬X€ÎJ§²Ž¼Ø™4_~¨ëC¨£©ÖEúPV ÄÖæD½ ("~ååøã~üùó ×,ft§À…C"&à€©ÕvK Ja7±Ëì1-‹fG#„~L¨MP'¯k,RøéÒ–Z»ô‰Þ©2 u1}øá>§p“9'è„—…ÚN²ñØÇ=Šó,Uë,Ls»A> ÷Sÿ•X ÕV§ xÓÛN¿Î Ô²xh«ô…’®N$Ôtì£t¢ÄóŽ®Âs£ùÒÓÛ>:Œ5ºëºE‰¹¢¿×s@¼ÃÔЪ=¬V‚ 1…Õ}5 ”Jü‚éœâˆ?ÑÊü莇ž0êµ\:é¹lA/oýS°‚­ŸÖUƒLÀ…0€kBC_@?¸JÒ§‚p# ÷jžÊì±®ÊêÐlŸNE´Ô“ J“îö[œIZÿyL¾Ž2wŸð+Üoªm—–Á8%>¨KÅû‰†«ÒD&¤ê£o†Å‡f·øp¸[74œÒˆÃ)öœ¡iÞãoZ_76ZJè-(7n^áIè‚à‰6“~ÀõãÑò§ÒÒGøð#`õkŸIðÊfòd7%ïy„ûÎ'ÂX äp_W`Åe^ïpõ“.Œý¬wÁUð~¶Úíe‘¹õ|;qÂÃu¢î>}¸‘·áÝ£›Bç ‰QÖ9ò…PLOd¢ß ݶÔG¤»Í=™ŠÓÂã8Ùo¢Îx ÜèáÕ%—®ºBϱ`öaö¨ƒv$:x\í<î.÷5^ g·§|èÃÝ›?Þ` ˆ/ÄB˲s½Po7‹l÷æ×ßøb 7a™ÈðÕ=º[H€ÐØ.>¿ù7í¶L²kÁd„3E,á>ØÿèAJÈ‘µKŽq´è©<Ó!„ eÇ1Tɱ¶¯ŒË(Fü*Þ8ZÔhSv7|XbÍâ¨ÓÔæ„.ƒœ­9.CKïÝfL¬iÇfXíå<Ùó½³u6÷~&äç¬/¹®Vñ%ø*Æ…¸>w2,îsìÀݳ©h²í÷PÞ#Îô+è E>ÌÆê p8±° ÔFÚKëjY:ëÔ—ƒ $ø ¶¡¢lÉz)úøêTUÿÞìÓ,ŸV¥D_u:ÞûòÔàÁÆm›ºo&·N|«y¬Ûõ¨NµÒûyeVç©ÏŒK˜ðŠÂÅ–^:†‘-<…»7D{h0ØÅ=Ag&@"ãQ_ø@zO¢3N„w»0f<ßÐè1œ¹Â€ÐíEr¾­Â‹#!Í4¥„‰Äô¦tQ©D¦~× i,XÎtä4eï4¥OEj'ÍÃ! +0¬„wË=X´cc{¤èäeƒPò Á@¾€âK6 Jk@ø+>E ¤9‰šlŽb½ù-Dà¾_FkÜØ”"hê žKpÊ CuZ À;Nè"(¥Ok$«Ê:1Ñuxe]Ñ• <0ÜÿZíÜÒž‰™ê…|I{/xHG7Z¿<À‚/]9ðHð ¥ID Æ¿.¼Uzpë’‰õ!˃ÑÒµ³c° z44goT1¥Í|îÀ'vP©>†¥ “¶?¨rªþ И÷õÄkB›Tf~h›’/„ß½ÃÝLn’ÄT7°Îb˜¡bƒá,Šå©j仪ñ¹Êyè9Î2¨>q&‡ °À1à:*W7!çê9Xä¶xxlÂèºðû‹¾êClyȿᕇmuïl§qÁ$ÄI.ûD ™kb–EÉÑó³J¦öÛ!óõC³èøŒƒœ·¹÷ÎÛ,!1çGÙ$ùÀ¢K>ÇøÜ×'`A@ÂðAL¾ÔJ¡U¿HäcTk¥öÙ¡Xó䥨œnü*T+âäµkë`-ó ,qs9§wÝÂVMSÜoOÛh3\°A¹w¦#LGò*GÜŸÈÂWæ `Ñ uå‚0û*¸÷G§Öo1NªÆèó´„Îô àd’4®l·Ñø´'ý•oË£µ€%ì•ÓŠÐî*`Öïã³Óc€ ·Ç»3ã¿«>\Ãß{_a48vK…—Ž`£;‡HÝ°5d¦6NTZpøŠÝñ’%_ÇŠô[3&¡šäKH<â™°=Â5ÁöA@ªÓï‘…ÕÅÆpǺW€Ë«uõ½ {SXЭ'¤e§tûRŒ¹­«I…<¥ó(]u…m58lfÕTÈ©kžU¥ÿÕÄ~=Í»Šß_ëë6t-ÊO†¥eæë'”g£FÔyî7ú®Y'DÜÉ îuϼôõY–;¡ƒ4²ÌêbßoCV37ÆvÅ/6,ŽuqÿYø .iüŒ§U}z–ž#ò•£½NK熻žÞÎb«d’gmæmé UÏsm’Žk¿±…êR¤Ãá+õÛçzÙ¤N»"5Ú*‚•Òï¸wÅŸ0/Ý×xDtÐ…ÞÉú‰Ú£ç,˜ 4à=i˜°ß’(šN8ž¹~OND§Ø’æÛ*K·áL/L}óÖ]1©ì5ø î`=Å@úåÙÇÒ{iÜÕ2…> stream xÚÅ[Ý“Û¶¿¿BÒŒ_$ØNœÔNÝ:Žë»´3Mò@I¼;N(R!©8—¿¾»X€Ÿ²N”'íË p±Øýí.X<,‚Å77Áè÷«»›—oT°0,Cµ¸»_p¡™Ðr͸䋻Ýâ‡åz­W?Ýý½öòŒ{sg\p±/¨ÊMžîWkñey¿bY¥IN=ŸVÓ‹ ð¿™PÆ,”‘'åíû7ßýè@À~n*`qìgíŽUV<)I‘äOuV³Õ:Œôòî1¥þc‘5Dä}YQ×äc‹µbfäbÍayÓêY½Z«/\ Åq¿I+jãÎñ—Ø…­_WBƒŽ©›†_¨¼ÜÍ>Té6«-ëðÑRƒÛo¿ÿöÃí˯íÏ êÛ•ÇÍ™yHr0$ö¯´Êìî V:^fýÚMˆ0X¾Yq §ÚT‰ùQ¹2ÁòÕ»wß}ýjÅ9_Þ½†NEÃu“4é>-¿NÒÐB»lG]EéÆêãv›¦;8)Íòíý<‰\3Ì—ˆµŸ89<¡ƒe‘â~Vp4M†'ô+>§/h¸RP+kÜ„dS—ù±Ié©=Tz¬Ëc¾£öÆõíy“ò,õýOôËÝp–çpxl´…ÁÖ× —17°Åb¥¼*‡—«ò·ISe¿¹­¸ ðó¤r½n£uS·Í±JÙL…圅\Ì>³V_Ë|W·œÒƒj„Ï —?Ÿg@‡s+ºø@ô­&ãoV4$+¨âØ1Â?Јþõç^°Ðû v†áÿ„þÉ€þa?áo»†£Í×A‡4‡ºDgŠàW£­ë1ÛôñE‹°øDž hm»‹[ôÚðà É[6[5ƒ/4åàHRO}t'6„;Àuõ!®G0 XÄ"¹A¸'µÃ=hôp/гq/4LG×ÈA?ͪ<’ôy´DvhïÚÉУ݊/SêènÍ´7®oxØÿD¿œV¸ð¸ Ày Ç:læ žµä¡•Àª°^‹{jå;¼'U•µ/÷6ƒ3f´ ÁÄókZ0¡&$µµ„NštT¦Æ†v>P ›pLËxˆÓprª3/¡t¾Á6=44œÍdn¤Aèå„·B>Ë[ÎTØRHÂ4ÇèBtÐÎ~÷ïØé¯ïn~¹Áƒ|!zv¬¬fø÷ÛýÍ?‹ ¢çƒ ùɾºÎZJòÅíÍ?O$¸¤Ö+\IÙøÞ~óûÛ×ÏÚ0èÔRH ü=T%rü×l—îÜXà…¡OÙö‘š[T‚™ Q, Ô± ÔH<çDüìqðàVW±²_»þ8xú¬p%ÉŒ2‡„0¥¥ðTúăÏî¼?Ÿu4vgxpöã!¸ñï]ìüéT~do3(ϤihÁ1ür"Þ¶”CçAõÝ'ì¹OØuK?³ÕUjNy^_A‚¹T Â/Êèk2#p% }ËGÜ%¬{ˆuñ6)k}hgÉ4JÏ÷ÀÓàú7!èl‘³–©ÓHî †“ä‰ÍeÍ£ë§éƒ ö*öû]m6Á®0M¹àðL{5*õ^rY›+ʲZ˜é[;ó¢‹s¿¨#Â_Ô°vÒ_Ôx>;ºÞÏÕµ–qX„=mß^bûA¬p›º½y¯×q‡Îý¡¿|£ù2²(îŠs*h!뙂à (òL9$0Ö_s\ÏãxÇc)&<–’x,…ã14óH´e˜ÏtM3i.;Ç™©ÿ]®3T'Ž‚^åPD¡¥6fêzHÇ{Ô…{«WQ›ýˆ‚^‰k ÎMs3wOE²oÓyQàlû¤VˆiÏøÙ[&1“¢5k6ÈŒ¼Åˆð ^¹MëºtZi‰<’F¯f’£ª"Ð }ÂQ¥Á#ôÿ B.5S†ÿò)£ÁâEæ>wˆíK"ϘJfb+E0S enŠ`¨‡õºË ƒcQÄW\4£­(bwOql Š8~Zr¿€Ea4ªRÇþ¦JÐÎY¾/«½ý(8u. ŽÞ´.ÝØ+ ˜­‰Pfé»|©ÛVð•w¡Õ ,¶³]Jß±êìÞÝ¥MºuwTTä•WùŒ¼±Õ±nºí-éwãk²vÐã "­‚!ôô¸Yú™d?ÝÂ'R*½ãĤâY0Ù:NF✞!®VZ/gß‹„ÀT…W]ä“z|3rHÍŠlÜS/B]Æ8èÒɃólp”UmŽUk& ŸFým–ÍS“ÖäÅZ¡ûÿÀW¤XØåþxøú#ÐK ~ÆĆŠ%£ÙLƒ8çóB6ÝRýáÕÇõ뀾HÞ‘¿èþáá~JÝðMºMŽµ'°  [ -×Õ7 ½'ù‘?S`øñX§ÏI(É¢‹@TˆÖ²b Ÿ},ëfí"Nà±¥š‹r×–0| ®UHœ?¬\G° B?uî¶äÜz1ô„½8’æ÷þâ-÷šY÷‹)ÓÁ€°þk E£õF7}[åD2H9Oü›@šu9Þ:›qVÌtÅÜçD Qç|4åàR|›„=§Bÿþ¾ÏŠ5ãS}›‘s~å¾WZoÁ¥é»0Ú‡ £²Aïâ3EKg{ÓÝA ©Ò¢Ÿ3aJÜžƒóÎwÌt烹Ë@¯¥.·º+/ZîŸùîšVYs¬ùð+>ü˜Ôþtk²Cövjæþ‡„lÙ|RĤxnw,pÏÅnjÆZ†ù« ãYm¦dx»{>þÍeXüÑ¢,Ö3ÜÏ]rƒ:…£ÛœWý †kÿ?å$3¶-+p'šgT 'Û’6 ¶IiøÓ”",ï-´IЀn§B¬M¤EÃË©¯ïnþ Âßyö endstream endobj 3115 0 obj << /Type /ObjStm /N 100 /First 995 /Length 2541 /Filter /FlateDecode >> stream xÚ½Z]o·}ׯà£ó^r8’€ ¶a×E궋¶±ýà:Ba$• IÒŸsxï(q*]-ÐÕ†=»—;œÏ3œ-i”BICC.F¢±NWch¡–J¢k™Ä=aMN) ­$rÈ©ó·–B–l'¸WÁR.Á8—‘¸”rŸœ¨.![.!Wé ŒTSRü'®›?Ì=Àªeì‘3öhµa\æž ïUçn¥ó_ƒRç¡ó p½‘U ’J!ÕA5Ê—±8 _±à^nó ’ï! LpÏ–N*[!Jªá1›OP#P(Ž? /­T'6 ÅßCÀ M©Kzã`¥)“3ÄЬ|s± ÒÉOZP•ùlZmrA[¢NK Ú ×•t´yOBMSˆQ¥dìQv4êz©:Ȧ»ù¬Ü¦ž¡ƒ:öœG°4­¥)Ø^/³J°½-µ«M°‡*\d¾%ܺ’‹Z°Ñæ½Õ ª‡&·ī¶2µ[Sh:½¤æÐŒŠ…_„Ö”{ÔZoŠ=ªÂûe©5ô<¥¯ºT깶ÐËÔ.{ÍóYø«U>a)@áÜ&ë#S“Ø|¤i(väV°‡0 \O¸ù ƒj  5¼Z‡Ûã (÷”~E¦£ÒæPÁ¨s XbÌ&£ã:ÔáhÓ­¶mÓ” Ûö4…ÂfoU`±0öJc(@<¾̃¨ªó’Öy·cOæ]H‚žw7 åäáÓݛÿþç4ì¾=;;¿:Ù½þüÏ«yýݧ³ŸNvÎ/~<½x›ÒûÝŸvÏwßæyq²{uúñ*¼Õ,q0Ô!;<°ÅAG2\›aÝ·ááð{vÏÎßœ‡Ý“ðàù‹§ß?{÷ ¼ûê«ðÍ7'øûÿËQºFÃËI¯± a©H¤½eÔ¨Zn”ão?ýõòôb=`ÔXËp‡¨Ð 2HDFˆ¦]7AZŽÙY,ÅܧGCŠˆ¿¹Ù_¼ùîÝ[Ó×rh…{Àg%&$©¸lã˜YVu mÐ=“¹Æ™L‚%¹Ç*G‘UA¦‹30á•õmX¬ J¸®õ¨Ft]Ë@#,¦pNa Â4Ê Ÿ[DÆ=°ã>2(êóÈQˆ äÕÍÄ@±Œ‚ªÑFœ5þÒÂ#Ýê§{£ü!y=!§D¸ô*ìþþ #Š{ ¯³Ï?ÿüþÖ…ÀIs¥Á1¸®NeÆ÷²ÕUÉ».]]Rì(à W#à†Þ±xôˆŠÜø—¥‚¨!hóݼ‘áQãµ–Èú¸Œ7`b[ºÕ-Ù«áË•@WSÔ´TÒJl}©ÜRG¬e1o^ÚXººà-¥-°¥À*"xÊ–J|Z–®VNì®Õ5!3)´¹øéùÙÕ Ý§À™)û§žµj· ¾Úý IÂÊÃÀr»þËÚþ0ß½¼8ÿøú©#ì^>yvoN¹ ï¿ÌF/?üëôd÷2œž]]² w>ϤsyþùâãéåÐÍ{9ýñÓ‡Gç¿„™§ ²¶!H=/?\ài"˜¼_8sÜ%6ž=å™-ÆèNŒ!ɉì„8QœP'ªÎYœ³8gqÎÅ9ç\œsqÎÅ9ç\œsqÎÅ9ç¬ÎY³:guÎêœÕ9«sVç¬ÎYsuÎÕ9Wç\suÎÕ9Wç\suÎÕ9›s6çlÎÙöœß¯‡qŒ`Ò#› `ÌX؇•Œ«GÁL_µh"euØÙå¡‰î ¤ ´Uï¶*–!²†Ž-YTô7EÆÄ2Æš$vL!ëÊa Òl%¸›ÝXŽì…‰í¬m¦‡TµS ½Æ˜uäÞ~Ô?ƺúè@Q(÷6¢Í.%1…Ö7šuÔUý4C)AŽ øÁfÈ&ñ€ƒò¥º™HµXlˆ×± þQa¯ÖÛfb(ª+âjÀcØVà”!¡¢’÷~TeÝf'áÔˆq«”žç±ÜÍqûê1ëö‡*(^×’t´!²P’uuDßà›èVã`!Ðã1àÖ¸%‰ÜNŠ4–kATòÁX )÷‘Ï´Q’ßò™»—ÛòÙáliÕž¹‰R4)¶kÂg‹Íg‹Íg‹Íg‹Ýg‹Ýg‹Ýg‹Ý§–Ý·èι;çsîÎy8çᜇsÎy8çᜇsÎy8çqà,)9‘'ŠêDuÂœhNt'ƪSÔŒŒ’ùªÌ(*({Æá%ð·¨l}’i–"?õ“L›nvfÅC¡Ñ9CV4¢ÈDœ]*Ûó¼ÙÑ*KBâ6V_~û[ ¿¡Nt[Û®øóàÆà—Çýý·‚¿'“?e endstream endobj 3335 0 obj << /Length 3878 /Filter /FlateDecode >> stream xÚåËvã¶u?_¡]åÓ1B¼öÌÂq&‰Ïصô´I´Dy¢‡CI™q¿¾÷ ER²DPšÎ¢€@à¾q “Á‡A2øîUž¼¢ðLtÀDB3PVcÅ`4}õËoÉ` ¿ý0H·fðÑÍœ¨DshN·¯þÑZ‚i;PFªå®5’&’…`ˆÀD „ªìÜ|÷êë»W_}+’!V)1¸{€=RÁ–PªwãÁ/Ë÷ß^ýšÈ„ÁzòÛÝ~oïêðY€ÏÒhøÜÖ àÌ-xŠ´(Òg·{cWn$Q4~×MÖEìîö³F[’P½-틸3ÅI"€“¥¨Çnâ]Q;vËqà ¼©T˜‹›÷ !h!@ á¡t“çE˜ûÒ¦­-ÑÕ»o/ï®ïn^¸Šõ±$ØÆ8Jü~ ÆiFlÂ< lã"·ìŸ:0?œÿï÷óY'ÆE’` ã€êò(lS’Px:ø¶ÅmÅ4?ÃJ P®ßÞ¼ÛbõÊI7•ƒ¥Ü#ÊV&k˦B+dsÓ‹÷˜Gˆ-¬“`M= ó¤Ù•x±ƒy±[F±Â‚„©s¶Kã4QŒCáζI¼ª<4Òˆƒ$„#[xŠw‘Xro¡‰5ì(B",Ð;xr‡Än§ã”ÊšÀÜ\ýóöü¬=c!ÛFOx2~z*J{Ô.zFnÙž5`ί.;Ò3²-ôäŒuœˆ BÁu(èô<|KÎ,aœ6·¼ùþv‡{»éR1At¢ŽB*¦–Èì TìŽq.– ‰4 X./n+Ïgûy “¥°Ç8¯kÛÞžÿSw+–[xˆgœ8N€þ¦´!¦°;˜»eœùÛ&0]É Ør&às9bðäÁÓ§ÉzÆîç1B™iB³Ý°@ŒocJIÂé!Á)V6÷¼½>»¹}Û‰±ÔØÆD؟٣01ÝÐ<0qWÔ»gœe³DpÓ„æb;KÚÃT¦ÙA\„£ÈÈæ¦Ý¹IŽM.JË Ä£Çࢴ”ÑJÑ)€è=ãT8ÛмÄEK$î8UÒCc<ç›vJâDÓb a)KÙQXh€x2¸çtG: zÏ^,¬Csq{u¹ƒ…7“Ç`a}ÓÉ|Ô…±´ØÂBm•ü(,Ô!ÛÐIè=ûätмÀAEŒ–n¦µê Sd¡¾g7Æ’bq¾8¸!:¡r#÷ìa6 ¹yûMiI÷4²-UÀn.BP%Ü’ž ;Böè=£jLVA(išÐ”E…&)'T(7ShsˆJP ¾¡jîÙV‰Ï–/ïMä€) à# !Û‰ÜvñŒåóFÕ W\ETÍJ€6ñ LÂÉÃRRRú§§ŒïbÆÓIEèw×'§L&Ã'4¦ ߙ͗¾‘ÏòežNòÿdc?pÿìŸËÇÌ7V‹¬ð­§"Ÿ‡ærŒÒɤú@kc…Hˆ(J~zw}ë§5‡¸CT€Ì—qòÒI¨$ìêë•dò¢(¿Ùxü‰-'üʘ¢¤µ`c÷Sf0|ƒSŠé^1K4Þz›Á/§à\ ß·óÈ-°$Ø#U¥ÈóÀÐù*0tþàŸE:û‘8JU±éåw;u¦‰’¶Aʈ=I"uùî>ÜáÜ‘´Úi7;¨†(Ž|ÏŽµîÈîºs¤Tä~~?ɦ¾óèTóÑhUNm —ÏüÓ«Š•.óyøÑñ¦>éë˳‘ Ïo‰ïß=æaõiúì÷Yù¥ Š¾ó<_ùFZ„‘Õ"Ÿ}cˆààTi8`Ÿ+ƒüó„Êa6Ï‹¿œH9 ¢Óúw'\‹çRûýºk]¯¦û®_³Xx$aࡘOƒ‘É–“ü¾´3‹e–Ž÷hgÙlpLÅ)ÐeÛ ù?R }¸Ct¤=û÷æAO1á)é@à÷?è©òõ4\I$ª™]ëäŤ³qä1#ᘩh¸=}À€Ð$ápó9õ‚íôAA…ÎByrÆ!Ȉ5ª2ÉQõWêdÝ)ÐxÞò5¦érô©QJ9¯,Z£ `ì©OG³›»"Wõ˜+0G¨¢yËídîn£ÁA¹hvÛh˜8£±îTsˆ;þ ôx÷곡ýA+ ÅzR¾&ìyÛ±ÎþX¥“¦³L#e_ƒiOx/ÙOèç“~—•±ö\pYc£¹ 6˜°Ç¯à _Zm¥t,¶&©*¡¿Bï¾r×U(a%IMˆ¼”ÂŲ2l[>¦³H—|GÁ6ï“<Á]:¨å]t÷cý’®Óö¤ÂÔ¯:w¹BáSqÜm˜œ=B.¥«õµ„œ'qB¾®ô¶¤‚s ²ÉÁß҇ܮ£†cüJR8//¿‰—ò/ê²æ`Tï¾@nWDTêävED©âÈ#v ´HlŠ ³…¢CöÞƒRüî›# .ŸG“|äû‹çé4[e7Þû¡X{X›¨Û½ë|Ö¼¡~SL9pýáÍÛÑã*ŒŽæÓ§I6ÍfKßGYÅgþ@î²Øs¹-×r©·ì“ËDa4OˆQ´å_œ¿¿»t'£Ýk° ´¢Æþ`±À‘?b x€P°Ä!—ÁÆS1Gý™f0’ú¹ðÃ([„YŠ|\®•.ý„ñ< ¿: ‹t™/ž[»Žæ³Å²Hs hmn Ò¼ûúòêüÇzÍ\¾ø¹¬È½"í– Âð/x\v$e%\§‡„)=Iù‚ÅJLÞÈkpÖÝb]ÌPÏA^ï'˜3zøç “Ãt²B©Æ>IQø Ç+ë— ’XqHC®oYWö‚ÉNö¢FæSÁèð-³,²9Vñã!çÉ®1_×4€ä‹lé.Þ‚ç)ÆfÆÄÓ<µ5pxÁk¾‰Ë¾r¡AAeÓüŒó“‡¬pç![ëœ×ª¨ùß9Ò™8cÿwØߨè‰t§ãÀ¡Ñlƒq\PÏ8$FY<’´åiɵ﷥PÃ]>L€#Œ+î?ƒ•Xv Oä:vô•™Öv”‚qà­íË€ÿ&M{• âkÚƒM Æ+½"ÉÚ‚uj©Y©nÖ 2_0þ|B)u²rÙãjÇpÞqÞzN´ÚŒŠ—ó¢,sæ‘®– DZqày»¯úa ßÌ·s™:«tRíƒNtke^ëd¢áù;v‘\<1Ãôzq|¼*\AÛ‹ùÄWüœ'p 3ÿ n¿ù†ñ^>¸½FÀª@æÞcL…µ³,ÒaŠðDlX&Îâµr6;œ5¢å@Vž±I„ÇÁÿÇfÝÿÇ~ETì8W×$²N]wÔÅFÚ^9¥“çEÞÆfįµÄlú±AB=ÛÖÕç°ã%)ÍóY#T£‰ôžB,r3±uËÍT-¨œ¾Iç<ˆ3¼ 2GÏ‚¾Îw€/ÆÜQ«]a«Mµˆú¼/—sf‡YQ8{M?d€ù™/ûø˜Í|Ë[ |-ק§tæ+×8T0x¹\/¶”‹ôP¹D»»Dñâ'±|¨Ö2ïlVv;p¨­FËü„›˜8+†ß–àÇŽ 3v`Ù¨·½¡eÒD¯-£P*$`´$8Þg`QŽ­J¯qJà56ÓÉbîçºÛaÞÅÀ±‘c§(/\`#jfÔè„ÞUòÅÈ$™»ù°æ7¼4 ÄÂ&âŽÏÚÁ]wp€B¸ƒ¢Ø€³yåñÄ^llöÈ™I‹ÿ#âÅkU;Rf|A%± 0/ÅØ#’Mòi>KË\ÖnÀóR-ÆÔ‚"KÇϾó”°æÔé¬0kçC!ÀÆ6ç_ ê/t/Ug„¯ã†(*±€G¬Gÿ„ööxZJIbñ%T±høÔÝ:Mt“£ùl™æ³Eëæa•Sé2h Uy_›Õõ·Ól”»¹ê›KâT4rIØï‘K²køãbt¶>®ú¤•´’g&Z¿MŽ~Ô^à¥F˜Q‘ØŽ "Oñ[@«X+_ÿ9‚I´ÙZoÈ¥î.—õˆëxºs3ëGw]K=4ÕñÅl-æÓ8—‚tͧ´H§ÙºR¢,)ÃúÜ%ÆZ¼èZ'²DØú­p€T(úä ¬å"’Œ§Ìý&{™y“àQçÏb£G÷ij¯„­áÍhrGâY¤ÁÌ­‹Â1¥¼¿•@ø§»ÇëRWЩÝg} #Z”·uíp¶r·Ü¡µxJGað>]”Ù1T59õ°š9‡3äK¬mqák‚<¤ㆾ‘7sù$u$Áßw‡Õ¬^ø„¦©kƒ»´ð=ü„Ùòñš6Š¯Põ>B¬õ:2Éìë'QàiÑn©É–˜áWÎx`«¥ž¯Ã%çÙ¸å…ä³±}÷ӧ慯C’Š ÈÊŒü¼YEP£Xû«nºŸ׈>XUˆÌ&%•Ê´ÔÆ—%¾  Ä$'y›ׄË-n[¤ñ†­/çU±v®ïN,žÞž_á5ö»óïƒwnKdßeË ½¬ÈZ—ûêuï=þ¡aî+ðöAl{;ˆIËAWé!¶Šc Q¬ÝgHìQmºbûËŽèXÖwý*aó>ÉÏ „µµêq™sÒà”²V4ÜÔOÁTM?HŠ–Ih<Í /Mîç™õIæó&áÕNø?»Ãç“o—[¬féb‘Mï}îÆAà(åÛ~ŽÏ’#I;ü[çÌë¦ïÌd‹ei]Ë%kߢLÓOùtJMË"-Ê㻼{ûÂZåÇ*••÷Hõùp._æ¨þeåg¿& ›åË0«GŽGkb„êç ”× ag÷õ )}&h„¯ñ§ÊÃpêÇfîdýp⻉Õ<¼Ü.y s`¡ùÒ+µÆÝßÛžr±Á|®f”¼/sB þ‡ KÕe*½šPÌKã_~!y;J/Ï®ñ0ñDý›B!Ñ^,¦ŒÜaû8_MÊ7×ßknœI°’ÅÀS99ÆB&Þ…‚S | o’ö§±ÿmai endstream endobj 3247 0 obj << /Type /ObjStm /N 100 /First 1009 /Length 2656 /Filter /FlateDecode >> stream xÚ½[ßo¹~÷_ÁÇÜÃQä gHÁ‰7¹:ŽaçÚ^“<¤‰Ñ ε¶Ó^û×÷J£à IUÑÕ5»ZÍ|;¿‡d8×RàÜRÈԌȔŒÀŸ®FpÎF” :ž‘P»¡¡/¿ª!§åÏZȹ·#P=dßv0/ÊFåepír]~ËŒŠQ%äÞ»Q(ó¸§hHí5PI&£·@Â2ð0iÅ PJ*¾…7èTÂÃIØ(^B¦œÅ(ü)’ iã~V‰ŒÂÃMÒ(êPs(9£ (±_°„b"A)¨bïVñ-„Ü •ÔB Úøm ¥°aÆ¥T9â„/ŠÐàÒA©¡/)͆¾dPbŒKµW ÎUŒKÁo«é” °´bèÁ¾4{_6¤½Þ#§ M9MÕžËÔTŠƒ2{0sÑqOÄŽ{´’ÉÍ5hZË-hoƒê¡æÌA)Tƒ*‡ÊæCuVïAª{7°ªuù­ùÒ°ih©>¯™G‚j¡qÏõР6ÈÀ#MêÐ îÕ¡{(¢5T­«iC(ô4ôèÆTÃêxNB/}Ppb6—z؃¤…Þ†G@í9%20ÐINyøXäDãåáõ9•ápñœ¤˜¡àψñ†* ÛxEàÊ©íÁÄ·ÂÔBÆ”Ò2ðjøÚðÙ iy V˹PAÎmù¤Á C…4˜p f7â£ÇoþùËUX<¹¹¹}8Z\~ùËø>ý|óóÑâéíݧ«»· I!½_¼X¼\¿Íãâhqqõñ!¼-¬:MQ‹9k‰>'×½á±'áñã°¸ ‹ßݾ¹ ‹gáÑ÷¯Ÿ~¾ûîÿþùˆÔh¹EŠÄj1ÜkDøˆàRÊFù/ÏN^¿{Dï¾™E‘¡uá‚~ï‘áMRpÝe.HA™!q¬–ƒ»D¸`ql¬sÁ@Þˆñ%™b³*Òð‰4'„ÏZ7Ã8>{súîQ.“ê£ôˆT%)GÓ†ÖhiXrŽ=ÏàšHÙ)ÖåSÏ1!Yï’¿Rñ¤öHÉi…U^²Æé?~þáþênÊøÈÑ2ÿ ‚} ¼Ì¯ ‹Kä¥ST¨½CD  »ôy”AMa+âp²|ŒlaU—5Ïd [¾^a(–¿wB8D¾BšLf Fœ"w£ŠuôC¸ž1yøhkeÈn“ít¬Ö)æ­FO4’h!d­swêq4óÍ’%Úè X‹²Ê¥ÍæE#úšÀ*‘-NâÖZ¶ Óð\(0' éŽ]vLÖÏ‹u êÇLba3L£1V\Ï¬ÕŒ× 0b aÒì ²Æ>öÅF(‰ 3UÝìß~Ûà—©Œ°Èx}¶)­N€$ôµHˆOµ–ßÚ_FoQc¥Íf8›ÐsAÕø*:œ¶Sü!"B ÓÕâ3aòžK Ý FŒ}HÙÁÚÝ„QsYl¹Ï×Þš|Œ”V)º­O ©* CH—:[Å@'Qƒ”yt 5ز ÆûØ{›±ÛoŒ’ÕÂè*¬›0}*ZÚRÅÏŸ\L)?/ÌùyL_6}à^š·Tði¬’SNmÑÀ‹fFÒ,éˆÎgfU6æañ§ÿlœE¶Cl…›/××ï·>˜I¢­¯(DgÞûiF…ÛûaL‘ŒpÛïi7îùtiQá3û=]jCàíË»(âa_Ø%Am_•pOÑÖ÷|š²÷Óp[®ÛïiÝ6¡Ò½-IèD«î Áß÷¶d¶òŸê>¹½yñrbK¯™–?;±Ù¼âq")H]_PÐ\ÇX,Îïn?^^!.ÃâüÙIX¼¹úõ!¼ÿm¨ŸøëÕÑâ’®nîm}Vì÷Ñ÷·_î>^{¼¼÷êêÓçOo # (ÕNˆêówøµ-€êòÁ‘@î!x¬òž±È»"È v¢8!N¨Õ‰æD_äœÉ9“s&çLΙœ39grÎäœÉ9¿SüŽ¸,qYâ²Äe‰Ë—%.K\–8gqÎêœÕ9«sVç¬ÎY³:guÎêœÕ9Wç\suÎÕ9Wç\suÎÕ9Wç\ssÎÍ97çÜœssÎÍ97çÜœssÎÍ9wçÜswÎÝ9wçÜswÎÝ9wçÜWœ9%'²ä;Qœ'Ô‰êDsÂ9»‡³{8»‡³{8»‡³{8»‡³{8»‡³{8»‡óÊÃßOµ,8Öß´YµFïl¥Ò¶`:²aÏó újÍ«¢†¥±ÓdM$š•Zi3Š‹³)‰Klº5E·Ä¼ÀóÓ7ço. ”OÛ­\ë Å”7wŒßD+klüaʦîmÃR•F£ÄØu%”ÆÍ[çWw{y3%‰}ì.ÚöÉØF–ÔúæÎùÉ”f€8LµkñÒcG–Ü)þùõô3”m *:øÞlûYÆ¡f Þ<Ê]¼þãåñ“``8„í—;ôĽnžãŽ_ŸN‹!q´sjX¶Ñ'´c0PÑ-+ãŸïþþáîòãO_î¦T#  óLÛ^kpJ¶Ë¸9;]¿øaÒÀÌHÐEjÑŽGØJ›%«\­±Ýì?Ý_þòáîþjJ‹´XŠ¡H¦1hÅ+'Ì'[VèïcL!9ˆíÛÔ2BÔ6X5­Æ­8Î‘®„ô‚9fË‚ËýíõéíÇéóµÔ³Ôu¾´=mÓË©1¬R…¨) ­S…TÔ¯²yìâù³‹—.~¡]²Õ.QÛJìc®WÓK¦mýËõ¤j(Éù+„f1² º‡i wDªŒÆÝöŽ>íH”HCí¦Ãïpûj´0Gcj‰6IáÈ[œñ Ì„nÀyéz+»P1ÛN‡X‘®›iÞaØv¦Žùᦰm[¬X›Â2ä¶Ú9mD®LáÖ¦Øà€¦XÃpȘˆµ)¢ÆÊÜƹ—P0ÚHÞ\'Îþ…â=åÎz‹6ì:*h&0¹ï‚0y½$äGÛÊ^ƒP›pûn=Lj æmÂw6`uÝà³v5qº†a‡/¸Ë¼Ö(„²ÔúW]ÌŒ¶XG… šdG{UÓlƒëÊ3¹¤j´#§ÂVlµj'ˆ8DFŽ²s‚Ú8’yu±6<±}+7ˆí®Ò–³PS·³á…¾‚ €(Òv‚XdÒƒaÔ5–ö³búÚ Ç´G'­»ç¯0P:R£ym²v ´ÔʺÜPµôUìÐÜæ%¡1Ÿ^šr“_b³cq+£á·Ãb;PdÔÎüðÛIFŒã3+½Të:N‡©m¶7˜„Ú8VËæ¦æòÇWÓï-[2eËÞ˜…›Âu£»üý 'úAo•ÆAÛ0¥-K¦¯žž¾>þý´ lMh‰€`û¿ »œMŒ€Ð@Ø.’C°K*;!ä`æ_û+h´i^K t¯6À[ÿ¢‡ßšâß´í¨l endstream endobj 3404 0 obj << /Length 3712 /Filter /FlateDecode >> stream xÚÍ[K“Û6¾ûWè²URÅ‚ñ&™ÝÇNìMì¬=©TåqàHœk%rBR;¿~»Ñ’F5vÕ^F €F÷×ôðÉí„O¾{Âw~¿¹zòì¥æ“˜%ÖêÉÕÍDHäQ&”˜\-'¿Mçs-f\½nç={©’Þ$i™á޸ѯŠE¹¹K›üzÍæ*1Ó¿fÒLÓõÖ?–7~1Î`3“ W ï¾Û¥)ÖÌŠvù~ù·›þâêÉŸO°—OÄHf\KG¶R“ÅæÉoðÉÞ½†EUOîÝÈÍD2›@c=yÿä?ö/a‘’ÃýÿüþÅ»£û7Œ[¼Îšû,+h¯73Á§é¢)«üo`Ié»ÓbIº\oC·Þ­Ò:«Ùli3½Zå5 ʪª¬hÄ&ýˆ”LæB)f¥‚g‰IèÓe±þã">-‹-N±Éô~åˆÎf•QãU0Ò}^çÅ|QVuþÎ w^Â&Œ·ìxõüÍÕ¸ˆ”ð÷¨é˜i‘„‰_ ÿt6×I ›É+¢r¼¢Îë²YíìpQMV451KŠˆiøÔY#Å梈yêI¡°13bb­‚}ÈGH¡ˆ“n)Ô™2¨OZêP¾ÆmÎ0#Oè˜&&Ÿ`wRñc¶W¯Êí4HƨýÞ¥uù¾m±X¥ÅmÖñ‰ND°q@ °{¼¼K.™ˆZ¹}ýö›c;€¥rR ÷eh“¹@AEˆk‡Òð ¨Tš¸ R·4*O#|7 ÔpîàCóØ#2i–hÝš9˜ô0Ý“ßæÆØ7ÔI܈@ítȽwçZ#n¾f 6ô´)©CÐ#.|SV4¶ZÒ»å¶Ê‹[°'Œ´ž^Ï$ŸnÃÂ(O8»gå°,¼H™0cmØÅ›wß¿?as„nÅiðÄè骬/LB0¥‡²tW•‹¬®Q1†pXžƒå®ªlÑ|9›L³ÖócYaPߘ›ñÆ\p”<{›šE¼e Ð=Àé|‰ªÔ¤31m|³H×kÚK·§"÷3 ¹É‘ô¿ð9_Ñ ¿³ª„³U±œ–½ý’¡‹Uà$<‚8¹ß|ù‘N"gÚª³ÅJ±È¶æ®Y96Ág[ìpX7ä¦ñÜ4ûÜ<ŒƒB"ŠÊ= T—úÒ~Õ-ÃÆ:Ó"Q{ÎÙi5œuèäüWü|»À‡¸¸® 8xN7/–Nÿ>Ðãÿ›{âkЋÀ[ððF‰¼”£ESEÌšÖþ?A;2‘Ù;A}þ :V(÷U!¥æx[n5ë<ÑKL9~v‘EÙPû:P•U`7]9:N‹tÈlÂN:L«©Ãa&ÎN+¿ªññ9©‹/àHƒZŒ¸thb/ghiIäóu J0¿,Kb;^FÖJFi^œÆ­Q„E–é耊q1Òqñ•s6±{âkÆybÀÔÈ!2ÈNçÒ©ÇÝ Ó¼%›Žò³XYÍÆFlŒëx4,iÁô>,!7(z>ôCÉöÏ'l.#›ÔNrð `¨£ ñ‘P ,æŠbñ<왇Cƒ¬Þ÷âóý°A#D’Öðt—˜ù¬CA÷úqŸ¡J m=•ÀÇ“À¶“lô|I|ô¾$6/ÈÖ‚™Dsp‘7ùtì·À÷Ž.ÕÖ]`tns1^ÕMšÕŒÖœa'ngØ¿‰`Àý–%oŽ¦¹˜íR´!„"£*«ï²ÈÍn öHG𘠥/‹¬óCé±á ³–F{ñ™>œ=Oö@&Þugôƒ óYAÃËh|¦ì€¾@AÇd>iKéèófÀ½5bßú$ã|ñ÷¯~}qÀGp BL´d“G]‘,jð‰‚3þþù÷?¿WAðoÕjåR_\ôÛf„鱯/GŠ•b¢ÃŒÉp®Üã¡ÀÌhkO2ŒÞCŒø—÷†Ah$[Aã´‡|e56ÄíûJ@Ébó)8”(¦"sšCòAAäfFË ç:ÃT ÙOIòƲT•‹§#áøÇóSƒG*§zs…ÆÃîømZÅÑtS.s0Òåãbë®yT¸ÃÄwÍãºjPUßéßFý‘Ø`môÎéßæàÆ^ZiúîVñ> àŠQ q±|Lq†Æ䦅x(Î8Égß°ºï‘àÆw®’b;ÚôÌ,F?¾~ŸÅ™„™(Ú5@­§Føóµ+‰ÚR’ÈR‰ˆ3¼øâ~•»rh¢S±m\Ôã|MÞŒs¹^Ï]ÊÄ¿…Ø´ZfU>ÓÐlû©ƒ»9è’hNY—âÐÌÄ;!+P²¡šô VéÝ]RxTÕB—1Ý•8]64Yßë.­‰F$Ê%ÿÊr\æf[…Ã2žCØ\”Ëà4ûžÔ¼*Ãjàvo×Í Ç‚k±—Ë3bÜñ­§ýýaéí ß#~Ìš¼~öŽL+÷jE šòvPzõüûg?]Í9w=OiµŸÞ¾ûÖ_tãr÷9Öà %ç×yC½ËŒ²ù°ïO"/ºxÍ*ü¼2¾ºHŨgäJ[ÿ‹ 9T‘»¢Çþvš¤úSê¾­Ò»õ¸ëèªó¿3já-hZÍ`—·îÆZáÝCZ0ãRfº›syÀ×Ìò¸ï²+ï3™œi òεßñb¡Ž¹öôÁ(8Û¬¢%„BW¢µþbÖÂ*ëñ–r\1ëáÍ ¦)rrÛÁ‚àÑI©É•÷]+ßð熯{‰‡~ŠíæO _¹„,ôõ‡:ºæŸÐ¡ÔÅgä~±oøÝ—\(‚£›ðíkWI“í¬îé§Â"Ü6 ôµG‚ H}~·ÎCÀríÁÉCÍ&_¯ó²¸äùxð ÕôÕê+£ëx‰»/«¦J‹`×:Uô~(ÊÔ;VÓ(§ÝØp0ÊnÑQmÚYŒXŠ* æ*½¥ö<}ã¦GÔ¼  òs?ˆºƒØQ—›¬Yù¬—œ¢ Íº£r"Q°s°ËvúFøû±ÄÂGH É"‰2éG Gw@Šï×ùu•†„¡|WÊ ”UIÒ¢,=…b6l§ëº¤‚Ç•¿úô7ÆðÎj‚`lO:ú‡<6EàÆ\’Æ–›þ‘á*¤E¤ûµSj›ÕcÔ&KíµI(À°IÈbõôØYxsЬÉHe8M¥jâ;µ(ÝŠ­ƒÖ_r„±ºÍ¼ÝfEV¥M@2šØ '†íÁ‰Q¦cÿÄFÁŨ2’ é;NWù²ð•iê–!eèÐÝP6 /®¡ª$×s· L›4Ìå–8×4eøHQg‹íLã‹t½>ÅÚÑ’>ð ¿ï˜û A kÛÌË_í,£dºOõ6ÛÀéáû,£¡dÏ`HÖ-³7†Óy“t—ȧe÷bÌÜùÈ|´L$‹ã½|Üé*ôqÚy7l•K.ÄŽÒæÝibñ‡+Sc¾&ÃÝÍ…u>Ç ÞœœÞ•u¾[P'‡Årü}:úR{P$Îpfâ.اÊ? ÎF].rÒK|&½to|ähBG{œî­¯4w3×kj]‡ùSuí‚~ÇŸî\Èpq§Ð·»/>ã”e{È. '\‚Y»_ƒ¢|vàø>ò@ÇÊ=ä©:9 DI/fÍùâèδðÖV™)‹<6˜WÆ¡JXðÝÑü”€fœ\šéƒ³VÝmÑëçoξoó>l±tÂ'|¡ü¢G‡ï€ZFèé× ÿ_ðªIÉ®ùGtXñ·Þ^W%†ù=;µ> ÃçÛ‚þÚàü{Û‰N/ ÕVÐ_½x¸lù /àKÛÑå[†ÅF^Rø5¸ƒRšJÁ1€pæLùÊmìhãåãê¿ÑZ Ü8vùíâ-7Óo³&Í×5­fµKb®¤ªßëŒ!ôºº칫Ðü/ý'ýÛ xm¹Ff#ð¬:órÌ‚Ù5;¥d_ÈóuôÛ]J R”¡›ôÃÄoCO$ä½×”¡rÀO½ÿ¡Âb¿Öb]ÖY_¤#WæíDd„¹7Ⱥâ—ªpÇè“R }Q´+Ê­£ä‹#÷CÛxì ŒÃ\^ìTœéi÷Ÿ£ïc-–mµ˜ðµâ;Ÿ _fqgí¥Þ_Ãv[]½>m!¦yƒNýNB½<<㹈~BQ |ú£O€ˆ6ÿ4¦ (¼ûîÞ9ׯ*i/W<é¥ ¯¤ð°ãˆ§¤Í‰³O´³oCVå4¦Ø[ºŸ—›ë¼h èUõ·Z^Sö½ô¼±âun)M…aî•C@Ro7›.¯Û©XQ7y³me¬¿4ÛßGû–®P%S§`ôÿ™ÿâêÉÿÚ@½ endstream endobj 3357 0 obj << /Type /ObjStm /N 100 /First 1005 /Length 2466 /Filter /FlateDecode >> stream xÚ½ZM·½ï¯àѾpÈbU‘–ÙdYÐ*ˆYE^Ä‚Ý`µBÿú¼ÇŽ!`Õž= Úê²øºªX_d‘ÚB EjY:ˆ–‚¸“ÈAS!!ÁÊ Jpo$4´¤$,tåôæ!'¯¤jÈ¹× P-äR„ïÀ\Ü{ ÙÙ÷rUþÚ%äVÇ»$åLJƒdåÝ‚H%çîA4w5ˆY½ms{d ¥$|A×B ¬>ÚÿÊLH•(üàâ¤ð_õ1K6~8Pã]šss J  &-JJ‚Ú˜›KÀçŽq´Q®‹kßÿêÁ€ƒªÁ¤ÖÈ 2®™ïzÀ§ñWIÁ||‡ä`µ’_ÁÜžøEs»rFÁÜN”Òƒ'J¼@)ž*¹`ˆg)XÂöL-0õ½4 b|8¹¨]ÔA i5j ®ÔGQ¬¡ kXẆ5¬ÉŬ»p†ÑX*gÖ¨20ã]¥qÑ°¼ÕñmªÒŠ”P­•h¨5wjëB=µWêCjh™Š‚a…&C3q+u¬‘B³½„rhø$R``äl˜Ñú@ÕCO…_î)ôLT‚è0¬%wß•us]C÷>(˜}œ1­wì>¥!ì‘œdØÄSjºœtHŠÆHÇBÐjNÕÆÛ² · ƒ4y¨{$gnGÜe°E’X-›%°ZöFf°úœ›p,62v¤ùŃ»—ÿý÷UØ}y}}sw±»üðÏ»ñüôÝõ/»‡7·?]ݾJpéõîëÝ7»G¯òx¸Ø½¸z{^ÁX#¶d'Ö£r?t<׎a_†Âî2쾺yyvÃgÏ^|}ùyøâ‹ ü[@µhÔÕ $vz‡ß’@űó·ÓIJ‘Û îA,Eª¤öØå~A<{òÝWD[Sâ…ûä7:wÞŽ³($åèt®jÁÆò a$ú‚‰£K\D±²UhŠÎ8ÑœaZ#Üm‹Ý·@€°GÄ= @ˆƒbt5E¬©‡Ìí`ØZ°lg†3áÀƒ¤Ü ÓW5mQ¯@‹¢#ÄŸ¤Èº@ ˜çàªè±r;¤ÇõQxƆ:i Ày<84ÑQˆL Æœ…Ø"õ]§RêC pêˆ €…\};ËDXŽœÅh,Ma‘uä^iÙ0ù,©|dÄv(hÈY²OxðNS=Qª„¦ºµDf†’vŒñ‚ðÚ\· ò† ¹_Ú(‹ÕñqÍdËj1Ã>P±O 1ÔÑlû4˾]_IŸ‰ü¡ä *›yÊæp€Áê$±v]‚q– ‹2I-0ù°V¬ªVGlŠR£{Ya… bµ$ç š#û‹€"½aCl ÀyTáÕÙ•Fá …t/gh¦áùSéÖ,ÀU¡vu{šàµ¦eG±n7…e;‡ª±Ž$Ø©G@©nÛ)ع—#bÈ~EO²®u`_78Tàz;ǺU«bATñGÈÆ SþǺɸ4l¶¬klÆ£G2Îf5ÙÀq¡@åÑ'›æ£JËì¼{쪧¬ÿLJQp}vßÿð@QÂTl¸ë¿þúú“³°×X‚Á³ž:¸Ð’ë©£eTy'ŽÖ>ò‹·4.'ŽvMþG[Š5œ8yÕS¨Ÿ*‘Ò öé@h½ýd‘”œ-œ*nnr:Õ¤XJ”“ P€DOwF„³~òh­|§*' ÄG£ŸÜ\ß]øDSP¤ÿcÚ“ÂsÔ|x°ØM8< %­ssà·{~{óöò ;?ìž?~v/¯~» ¯?v&Ïßüëêb÷Ë^]ß½çAã€JŸñþæÃíÛ«ñNöï¾½úéÝ›‡7¿…áfk„:ZãÏßÜbv(_0õ ãJ⧕B'a“ðIÔI´IôQÒ$ò$&g›ƒmö9Øç`Ÿƒ}Âð Ã' Ÿ0|ÂðÉÙ'ç:9×ɹNÎur®“sœëä\'ç:9×ɹMÎmrn“s›œÛäÜ&ç69·É¹MÎmrî“sŸœûäÜ'ç>9÷ɹOÎ}ÏùõZy/ÄéMFš"µEáiyü½?{}úŸ_þöþêvÅP˜áað¥^3x.›·,œÃ¶Ü)\ù¬Ã#JÉàž¢ð¸º—‘¤xMpj÷忯, I‰ÀÄ$z_Æ°ºFÔ4ÍŽ ´–‘=.XµU˜ã ojDÞ2ɽ±ëœÅžoЩœ§ ^¬Ör<ôrd­*yÃNe‘ýþ<¡b\Òµ!¥D!%î¯/qQa^µ‚Ù­E„F9»µ.H’n×­õÑsñÄ“-÷2¶HÎÑÔ¶8’† tdÖ<’ aS‘ÔPBÔ–F‰Æ8(jˆO3 >Ò{ÛL <ÎBÐœ0 |fGr¿ã`ù'°†Z„§lD‰ó: á½n°A®&&DjeÁ4RÁ“a”a—uKALU”4úôÙ]«TM‚‰Þà÷?¿_×E0k™´õq"¾€ànúµÎU:nüYBιÉ1xÅ>Ôr ìÙtÀYlb*C±=yš]r¶yÕ­·-î>æŠäŽM‹‰iw–²Œ`Íû2 ›ÂËdx žr;/‘7Ž'MðÕºà,‡&l±AΦ> stream xÚ½ÉrëÆñ®¯à‘JIóf_üNŽ¼¦ÊåÄ’sˆüÊ‚$|²üõéÙ@ITHçBÃAwOïÝh<{œáÙ·8\ÿzwñáNg„#Æ%Ý=̈ 6“Z ÂÈìn9»Ÿ›Ëk‚1žßdUUn/?Ýý ÞÃÃ÷¤AJ€ê^øáçþ~¶Às‰$qÛCsIô¼^_^SÐ{¸)¹ÝMˆDLÉÙ5ň2s–ö»©Aš÷D”íå5£zžùË7—DÌë¦k²]0s#üU¹h²æùRŠù¬p5_mù¸)–~_Wû}‹Â_w­ÿGý–öp€›y“u«¢ñkÝ*þ{ƒüõ»ú’ŠùSa?[qk y‘µeî9îüAȈÀŽrÓÍÃ%Áó,©¢îìT±ù¶©-ØÏåÒÒlÿ":ÂôèÃ^8WÓ†Mµ_ÊaOB*D2$hBØSi°½4–eSä]õìxÎY7~}l²uk£Ôü¶\—UÖøí,Ðc‰çòÛñ…Š´œ0Æ *3fȘj@iì 0‡L4–!­ß“ù…¶kvy·k›O«º [óz½­7Ŧkýó:ëò•ßÕíw•›¸T$¸Ê0A’Ë#ØÊqoBC’ÃCÝx~0F~Œ´”22ÿ l÷ƒGÀD…Ĭ±®!>üôí…}­|ôà ¶{b…†Ùünµký.Ï\¸KÊ›rÛ•uÀX?Ø+ÞïØf ö¢óªÏeØx Úoµo’çÀ‰ YD¶Yó6™ËäÛÛmU o‚°gòˆ§Àµ«½±YA᱄¬2r:ê¡špÐÅûÕÍ¿>õªrñõÝÅ.¬ÍsžQ Þ KJÀ§‹Y¾¾¸ÿ„gKø#fôìÉm]Ϩ‡YÍn/þÂÂ'u¶ì!a!=îÛ»Ÿ~¾I`)-ÏU€ª+9Æz“0 ˜ŽAžƒw+çG¼„G2ËË〈sòöÑ©Æ-äÕn^²[«”0ˆP–zk¼o—ùŸÖ»õ¶=d ×i¬ÎÀ®9âF“£U‚5× ˜H9«™µ smp*ü­c \Áù›uæ˜wM½ëʸ¼µ1ÊÞd—CÔ¥ÎÀW/ªðÖ”Ý ,Ú.ûü=2óPÇÐc³ µ©»º{Þ_ŒŒ'^§®’"ðvp&Ž œÍés]¡$¤))üš[7°’_Öþê£)ÅM 8HÈÀš¿¸€Y xƒår¹íëë>ŽûšBæc¥ V0e~·=Ȳxðäxô²¨9P…0Ö6ÇÉ)>$”L ©Â.ÑGüûy}åïÀ†»ßêÅÇÞ·¤^‚`µ>TO¢ ãÃ|&˜D\²Ô“(…”ñ¨ âyðqç£'áƒ#P0اaÿ71jEúw›2Ϻí¡ÈØ$ñó ƒÕ!‹Fô ì)óMWÝsüécŸÁîÏ6á©K`‹,•$AÂJDÍL"9ÕHË“,Þ@RF<$)uÊh’Bæ$Ær˜¤&*uÂòͲh ïÙj²äÇòsò»Å³¿Ú†”‡Á…ϱ§À#gÔ8c‘P*>NŸ¢d¡dGåP礲d”_à5 ô'E-Í@£=$OP†ÜïZø^Ðkl~+ºßæYìÖze4ÇšÛD“¯{kHd¾çPè¼®Ú<ûÿQS?EœVc(Ò'²û§ïnƒJ·uµ³½«ðÅóvÕ2ë2çJp_fäaeÞzý¤H`Çä¤IYQ®Ÿ:ʳ2nÕ^yJ}¼?âbÙ¿zšD¦Á½a9cB!Âä)Y8Ln,$‰ Ö×BÝWï³vÂXáøtB]ÿFÓ1¡ƒô„B­-Nõue’ÛÑ×A–>ŸœÁ×1^S“÷q{Z5&C0È—Î@©í^² ¡¼­ñ*ÓZòòÓÉŒyùˆÎ½VÛjd/586ÎÝm5¼ fúbÅfSaFáŒA…y’õfaâ!a*ŽÅ“’æµÔÐÛ#R¨1úMaŒ5/µ‡6µí]Ù›Çs÷‰žx­ñX(~«sô.{oŸ_iRb–gèÿY@PÈìÓ)oE}óö-*w›”¥ÃëžžL$e ¥C£aP2CßÉçƒêgm·ƒ ýÉÿ×Üù6_íš)_ψ}Ѷo—)ˆª‘W”u'}²¶Ae¯4œ°µDOê+jD“TA•ðJB\Ô§“ÌÜ+"ùЬ™Çñ§ä£{” '0¡/¹ï-ä®ÑMo!w÷븰Ç?†mT› 9D P"*m.t! Ù“XHÔ‚«jù~°8~Ž“FŒñ¯W/ æ²lFÎZ@LÉõfL$hØ°“J‹Më¾ ;ÉîÖ‹PC•æ]­|ðd<ò˜—ƒü9 9Œ ÆŽípß…„ð”æ’A̺o€Ätä–;ѽîcœ„ø1í1ìɬëü•àå“„Ø}†èxì¼­·Ë²¹‡ä0Æå$ eŽÍˆ ¶¥m̈ˆmS<”¿ßKþ)¶âö N Ò’OªU±vl‰Ù hŒVHo'q6+Åïšq>Äo·_£ÔÑå1l´ßúˆx1›ƒú{“¯(=øEÌ9”û¼a ôŸ…¯]D›ü˜ˆ-R}Ô$1øB]—XÉÓ XC”ôýf¿í¾4 bµN›3`¥úCœc½ùØÏ;'¤ÍãíÀ lŌڎ12$ô/ûé)çü ¼æó¯üHf“à7›W?§77þr8³Çg[þZÊ£¤À¨•sß«l·éU~}È=Z[ Ð Jrõªl3u´’º‚i„ö&!áRª~$'&Rà d?˜Î£Æ•ëF;­dü(¦½³ƒoîÆwؼݤ#ÜåqJ1¨;§Ý’E˜J)J?ªé&^l­æÇaŠ'ÍÐý~•8ÄÄéAf˜8 ±IOÿ™ì!Ât»1G·p­ÁçvJPœÙ›ˆÆ¶íµêÁVuÖ%CÙÀö‚ñãS‡Ü“·¬w‹8ø4$@í{yØÁ˜0E´™Ìú øæÂœ«Í4Ðh–f:¹DAæÚÍÕH"Η:›{x™ƒìœé ?°:œPÞƒÓtXf¿2\IöÓuaJUø)U¸iq7jÑÇæÙ~êÂ>†éü€›?–ûqßWnŽT„Wow‹ÖÏEzP Æl:‰bØãH)1žûº‹C¯Ó ,Xj{ØaèuY¶ù® ­m½¯vE¾²Ã7•,ÛvÇdƒæ†Y¾àxè—d¾ªwÕÒ?.Š¸¸ðä¦nãT­¥ÛÜ."œžÌW'ú§x­&Ö©² »Ðú–6Œ¾hƺo2O÷ýæµ ·«0þkwÛ­ ŽÆž˜+´-†½º–Ëu„!Œ{ºÊ‚§XE fYä°5ŒúyÁn6-•Lø†â1qŒSÛ#ïi8¥‹É©q±A^ b\Ø©4sœ¶õ ÌçÛ3¥~j˜qØ^¿µ4¨Ú AE¥á,ÿM§ý endstream endobj 3438 0 obj << /Length 3400 /Filter /FlateDecode >> stream xÚ­ZmoÛÈþî_! @!ñ†ûJ2‡ûúœ«ŠÄI¥ê EYÌQ¤Ž¤’óýúÎì,ߤUÏmàj_gggžyvÖÁìaÌ~¼Ü÷¯Ë‹ç¯”˜qÎb­Ål¹™q¡™Ðrf"͸ä³åzv?¿¼âAÌ_Öuòxy%t0ÏËužfÍåÇåߟ¿’ñ,b±1 çfWrûzÆ]×wª`€tþ ÑÉÌ…ûâÙ_…A4°öÌH©‚)ÎÌÞ/Ÿ"P£¨ˆÅ2hëNøî`#é»(d2)yáÇd= cßÁVTL°‚‡ '®YÄgÎÚaP‡o,ÓmæÉÅß´Eº1IÂm RMZçûa®Ü}ßg)V6°'Èô¬FÄê~Üýx1»·½õ×\%úדF›£Ñ6V+á,ŽæêȈ-»Êœ³jºÐá.Ñ´±ƒDÎß[â‚Ü"ÄŒK¦Ž‚ö’Àо0œ1T4Eþ°%MBí®ª]=¾Í¡!Ò K~ >+² ‚ &èXŒí“—ûCKÕè„M–=AM0îýaÕЩÐ`à¾ð'•‡> 4²W Á ¶#Ô¸òì»Ó®Hû ôeTv/ˆJ /VW`H5µÐˆ_Ê <ÆÀ‘”©…/9h…Ákä«Ø©ÛÔæå:B+˜Þƒ³¢Ý·µÇ£î€ðu:C#§óÜÏ!a€7Y½A"™ Оšà{3{óáÍ»÷¾÷\¤ç Z"¡ÏDYX1V–®¢¯Å¸ ÉNˆex°+Š™ ͈5áÔ6¼Ý,/~½@ÌøLiàiÊÌJ X—î.î?³54‚Ò˜Œ£ÙÛu7Ì È³÷ÿp ¤ñŠÊ,”4S+ít›ó€&"WCì5!ŸS%…¼Í“"ÿ=s ¨XìmO+š}–æˆÏøcB±ÓU…´ýRnÈäü°ßäüNOåÈ ß¼[œžWr¦8~Åp¥˜0QÈ¢Ž¶]¿}óƳ¤1ÌmþkšØ@4]ô_oï^ÿàsä‹Ç—LOÂÒꑾp͵Îx(Z—´[l¨å±:P¡ÌºAx¬øM“¢ðù ,ìî¬ïND[%½LUé’–ôi0‰¬Í qØ­ºrå$wM³¦q‹/˜–GÞe7\n ÷ß?†Iújb]dù‚²¢.ëeõ1MÙtÒ¥êà¶nûžõ(OeF– ”Õo¨´1¥“ä$íå2ct]\vw¬#ßbêV‚p +J è’iq°0†õ^ƒ«ŸPê §·æU–&6÷`gu«Ú»¬¹ÎöÐîÒU[úˆŽQK`{2âÜõ˜°„óƒc†Ö^VÜÝ&§lW981zmìAI¥ðÎÅ"ðDo°ò¨˜6|$Ÿði‡3-Æ™Û1)ØU»Éáî(½?ÙBãFiáˆîàÓ¡º®ž”Š³ÒŠiÞȦŸ7=ŠÔ ©—=òŸ·Ëx ?_ã˜Tl°‹Ÿbûw¾l@š9JV Xeó®IëÑ­GÂwozS䀘&ŠfRÁPûÿGNÁMÜÆDð§×´°k¸‘÷Í:ýýãî°Û7§;“J‚òo°3© º(>ÝYʶgv6¤·ˆìá^܇… Tv;m]æ™\ Ôû8—EÇâ,2ñ4‰qdédÌÝ=L¥§À7öŸc¶}Äv±jÊv'ƒšd—uoj­Í<`±ü>Û[ìä þ…~Îã¯v/r'¯+ùVè# ªÃtUÿr6'4 Œ#g­.¾Úÿr·íªuVtk»'Â'=»3ÆÎXº Æû½{ûa¹¸½!@ûîæöÕâõÍðØúáv±|FÅÛ—onFO¯MA¨½ùñænéëtý·—w/¯—76:tˆW|ëðÛ`ÿ#cTkEêžÔŸä¶6k€£ë£ûnçmt“Ù÷8êÜ>ïn–în}-7·?øÿñãT÷=Ë:¥Pô$ìç```uÇÆÛJì­^áRÿdIôfìMœ0˜ ®¸yOÜŽh<ÐÐýk3€_š)Ô£; éþÏg»€k°Væ€ihÄĉû¤fClrc(bÒ¨è¹J¸ÔFßB3ÒH¦Ã#ÍYùÐn=ËÆæþúqÌ‚èH«ÇÏIqîߘðA!’rj;¨8K~c>~ƒã¼7v D½…B‹­PM¶×WSÜ„6Ly¹|šõ)-‘¦+2òÀRïvÛwnò]^$u7’ ;vÐÂT~Üï =-ªæønC!‡Mpת)5 C†.Xœ ø=3îbMß`áDÿËa*y endstream endobj 3452 0 obj << /Length 3486 /Filter /FlateDecode >> stream xÚ½Z[wÛ6~÷¯Ð#uŽ…$’ÍéCâ:mv»k»{išZ¤-n%R%©z_¿3€7Ã’w÷E¤`Ìå› Àg÷3>ûþ„›çÛ›“Wï¤?‚%aèÏnîf™3‡Lbv“Í>y “ó…àœ{W»²-6ù|á‡Ü[·uZy3ÿ|ó—Wï‚d³D)‰tøl!"Æ…¡p³Â1qè½›‹Ð«ê¶NKü ½$¤†º£ ‰ò#µ,«ºÎ›mUfEyOímEMíÊ XV›m±Îkú¼kòlÜÑ´ÓB%,z±$ñaÁz¡úøãµc?>ð ¶WјEÏ…—ÿ¶+jš/ôÒ¶_™-!™”pƒ¾.Ê_‘…‘×´é}Îæ‹ Þe™ÓLJ¹à^Š»c¯…)*zÝÖrï÷"3‹Ö<zêÝÂs›×wU½1W¦w?ëv•6v®¢]MúEÌ…¿ðeÓæiF˪î&ÎôÖùxÏC"È;D!û‘åñ:sˆ(FÊö€•f茔xJÆÑlრªN‰C£ÄïË6¿‡•$¾wJË9Æ^ž®é_Zfô‚k^çÿ¡?YÚ¦íã6oèoQÒól2æÝÜï¸wÐ,þ1¹\“qà¥M³ÛèwPÛ*~5Š4áT”°X…6–­‹U 8±}N]TOâ%±ÓÉùÍÉo'¨ê|&f~²ÌCqŸ~2[nN>}æ³ AÄ,ºëfæ3…Ó­g×'3Ð22´0f2&J" I]ëY½ê»u•ºˆ‚ùA`{¡pžAøqgÒYµ»µ1&¥˜> Ы´PMÒ¶ÀáºlÊJO¿ mêéJ~ÀYLPâýÅÍù÷çW®%EL…{E úÏ;ý0„Ðpÿúþâ»oc4Ù˜ƒ£dEDZ«ó7\H°(ö°œLOè»ËŸÞ~8Ÿ/ØæWçgï¯ß_^¸Ö³@vò²æˆè)"ð0aš±¤m[T¥¶U_KJ£±ÀcF|6Þb`ÓÉ8 ÷×Ö¿vÊ9=⣃i¾å δ„ÆL”†í×^AlvˆqvùñÇçÿ|†A]³ˆ—k~žjzؿƪoœaN‚BŽù„ÝÑXõM[ï–F!–.6¹sÆ&ŠOâBM²>-^;‚‰ú8òÞAXw3>ãÛŒdÀ~ ËSaüK„hÂl$$ÐPÏ_;8‘€ßo¶2èÒ8€Þ·u¾,r\:’ ¹+˜VQt’[v»œª @s” ó®Ó>íq:lˆüðÿ h¶ï•tÂÀ>^,i&fwÀú^’ šŽL’iî1™3„NDƤ¯Æ<O»G¿0ëãÉHÁвì†?j bäâ„ùʆeq§+.½óã\}9^í¬ïWLÔësé>?v‰ð9HäMŸºÚLp’ÚPu_§¦½YU»u6ŽU÷¡¶ÉEÀ@n)ªÄŸÜ]¬ ’pZ«P¦Vqÿ¶Ë˶°µ‰ßuØY7]¼å,/øê[_¤Àp¤¦°h™wøS騈õØžŠXß©hŽödÍÓ…fG¯m²Ðl¦ÀÂYõJûçêû“Ù'ÝñzwÛä˶¹¬ÅŒ¤§VˆçÒGE[Öªm¾ØiSÇT>¬jÚN«addÎ5oR»˜%«i§¼w»rÙU¸­"tÊeŸO‚U&%&#ìI£[EFê[zeÑjÌ{íâå¤s¦{ꪫiøt yÇgzGP<†Ê—ã¨L¸¶pmÆ-ƒ0òV` Ö„éK–7Å}‰R¨&Üè5Ÿ†š›Ö¨£NëhHQÓë®Iï ÙÂŒHíȹðŠ j=þ¾­š†à'0ñÀ–¦ñ…ü@Ñ´”îvÅê…C?ÈöU0)"À‡éV ±wiNº¦ŸERÅâ$éÓ+=Ç%%(ðF³Ê'è MÚ”©3âË\áÿ\‰H动„Â):ñý>Ì×f S ê&”Bvï[ €@ŸDü&÷J¬ÃË6W›·”Âÿ:_JŒÑ{v'“]&ܽKŸ#Ú‹cNzziè"/’4Š¸Ÿ#@N2àE’Eà-+î°ß]^ç%é¬ÑDʘ7 È–&‡#+Øÿ¶š¹ìñæ›àLâZAù‘mþÂE43Ú\ÂÂ^iér`9¥ïðI*à‰‘’Œ;(té8Ò#hs•A÷\Ä"màß8Oå˜R]¹È¾ÝGWI`h< ií¦ o·(¼]±Î³«’¶…TI‹ddR’];SW‰HèƒÛ"s{ÞWˆ¬g¡2èSÂ(QÐo”ýåò­+†-úÓ`«ÉÛ±W\ˆ}Y™.æxÊ®ÿõñ¹©ÄÁ¹xŸWîÊæqÖ[KÓ¹Z“4³©ûjr]0ÿœvC Š%Õ ô› TJeÎaàÅæ/"’A†ŒMîÇ}Ô8yÀ¨iˆŒk š—êà©2û$r„58ÉéT%Äž ÕÖpJÜ,ãÑjÄ ìô¸Õš?8¥5„æ ´nžƒ@(„  ×Å’{û¥Føz™éõ‰$öp ~°ÌZ¦Þ>*󤳞7®3#¦â`¨ÌH{›6z³Hƒßº‰'n?úáA|é: Ñ‹Þä³gÓY,Û:“à/'ÆcJf[)íˆDõj =£'‘‚¤~rXPÝþÂîÞ–Žx 6Mc‰.‚xvqóÉ…ö¨ñ9á¬òÉ)õñ“J&{á^ì›æÉ¡ò×Nrñó¾iXb*ˆ  ‹ÇÏ&°ÓUFÌ6½ ñw†Õ±þâüÃ;É|ˆZÄôpb ñäA!“Æš½,`0ª“fŒ Ê#ðßç fT/Å?V^]ܯÚÅŠú¡43-çËV‹à¿}âà.isŠGj"`ÒM¡¹¤:DÑw*úÖM? ÜáÓD €Û¢/I>‹( Ûqš¸¼r^°ñC€Kq º |—öÒæR‚|ñ¶Ì½NóÝ'ã"–ƒ0ãê‡ëƒµ½Sš#mÌô×dº¹-èóСÏú5t åóƒ¨3)¾P íÌŸ&E†MÇÚß 0ì秕f“> stream xڽɒ۶òî¯ÐQª²h 2U98^’y•±ýf&os| $ŽÅŠ$*$egüõ¯7P„ÄñÇ9j4FïPˆO¾?Ü]mù†™›ÞvË®ªwŦꪲåÅfSÏ´¾¯vo…VÍße½ëšzÃdú VUS.»º¹“å»vÅVv¬o…N¹Ý×M˜p`x®â(·¹?e¬7e œY«€I8G’û»ÍŽÔtQòW¸Ø”+ÆèÖM}x»æIâ ån–ÄÓwUSï¶å®cÔwx®¢©Šì„Leì¦WÏ?½|†ãL| ëü«fàž)¥¦7??þ‘é¤0q½¬6ÅB`·ü•²é¶š¤ I ;`ì©=w.'JXÎö·ªÚ®©3O"8ØêÖó!¢¦cp[ÉB[GÊHƒ¤°Ûü<¡£m:}>S–Ïó%þø£Øî7*t >|WÊRôá].vk 4¬ù»«;ÂM§Uë‘ A÷ß!²Ëæm)llmÇ”öM,½«V¥'YŽE9E×`ü0HrËßæ°ë*Hjº©†8âa°©›¦l÷õnÅ!@ò¬Äc1öm÷¤ÊcG:ûÔ½š8ŠA9k_,+Þ– ûT™éͺò¬x¾ÂꊣjwdIn|—öúž1ámñZOéUܤb 8˜mBÅÆ™Àîôklc¡r~fe!Yã»–Qµ[Žœ;1QlzéQÅä%OHø\©ñÌ%SÖöj³*›qþ“ÞþpÝ—²>Wà,M®BÅYð†Q»,Gasˆ•Á!Äï&à’õIä{^ABY h)¨vâR±ˆÄÄb ‰QCk‚Žq-hÆäÓ˜ .gHŒLYÖxÙà8t§ŒX4‚8°©•G¿×öîÑ'NL©´×†ËÇÄ߈ @â”Û³l"Ô¬2ŽçúÉzTzAÓÌbÙÎã£ÀãxŠæŒó½wxÈ’ïíÍÅœ$;Ÿ$Ãà²Zp }Þ+dÞË4G®Ey²ªÚíHÌP„Pdt5ô1GD;0üòb¸•VænÎÞ>' È/͵?ëëÕ‡7ÛÃv?&•$矤¢I‹ á‚twkJ°fÆäÔJ1qÈæܬ°B€ÙNÑý·~M`†´¼öHâ±Té‰:±¼¶üýzUl8ÉáûjÚ>ë½ÎeáÒ(SŸ¦€•÷bˆ„Žž(ûCåEîr:¹„•(‰/£øÆ`ûWt¦þÖÂB,¬Þ4øã•!ŠÕýÅ[¢ï+Þ ~ŒËôñH±š¶ H˜™$ÅeMõŽA{×ÕrÍàuÑ2Œ‚Háwhø8Óc®…$¤õÎO‚i43•M߸”B Õtð]±ÒêJ`Õ*úÇËÖJ°âC„7l/;¬ïPΛ‚7¡àoÉUŠÄÑǤ>g¢Óò™ï ¸½þïå˜ A¡ç¹§q_}¶øK\‚ý฻ۗÞ êøËêƒUÍ_RD€]À«¥¬XÜñ—µœ¡ñš[n,dæ8Ýàt”`û5¥ð8µgÖgS÷)ƒž{¼ é!9—%k kÇh\t­÷,èä6ØúrL,üêŠÛ²f ‘½÷JLK6ð­•Mj$¤B¨ÎÍ@I!+óêÄù­¿7€RK☃N¿¯6†-¯)ûë·týcaZGIæ¾Ì {G{È^ Ó݇’·E}D `J<Á¼ãƒÏzµŽ2—Ÿ…ZZ£aM[o¼ii«% Ó¡¸ŒîvǤ’^!ð¸Þ6|\œ8´rŸsàD ’Þ˜S€e¹ïÎ,¤8µoL½}<äß ÄðÄ«{LÔ™«>ç¾×Âå‰cSùŸ³±‹'/n~æ‚ý%Ö]«ˆ çÊsw(wïÊû²±o™ª ÷36îM°/ûâ¾ì#0Gµè™% ^ „«“æªû¨ Åþ÷øq½Xç©Î§×eÉ“×eï&v­Ì“ã!ÒÁ!`*ah€½•.s*­ŸVh_Üò¼!õkvS«$mëUu;Ú$&1AF iõ›%W¥ïñö8åË A6ö¨ÒQüL÷>Xm{¢»SöjØÂZW HpVüsQ. :¶,%ïòÜqIqèjlz-©à&øRûϵ§ø§¸T*h´: έr>8nÛ;+wLüFŽÀ´3¬½×tˆ7Œ6%'Ì8UûÆg&E;" ÷Õ±ì ~ß,$œ8ÑïÄÝ>F¡Td8ÙTo×Ý|ÝoÓB¦1þBZuºoÑ™°B…™@6ß%Â$Ll‹;^A†‹RܺùA™±/› ­Ê}) 6œäN¤žÞÕ$0@[ÃpæÝ#Œ°~òÀC¡–+{ŽCmæiÀÍîÃG!™m ÎÙn%G8Æ›ö}Õ­ý:Pf›©j ÉÅ]ÇŽ,®¡´¾Ÿ«ÏÎ ÿlàzõìêrä±%3àÉ,$׬Ù/|5 öS¤ÝŠ)i+ìÅ‹牽£Ø ‚¢Êõ ÃÚ2­r©ðvPíä—üûÁqŸïã>\!= WR»ã],­– ŽO"ùV«#gOÜe7‰ï²ÃH¢šDM[oA&ñD#*-`ú¿=t¦à'øYSHv–KzqhÉï LEƒ “8÷ÑCÊìÿp}=f6ê[—)O^þ|ýäñlž$¹4'a𫙉§/g`!ÿÆùÅZ!φ}"AÝJðýc¿Zðø¤ŒÓw-{ÕÀ½jÐÌQ5ÞD5$Ä2ÈN3´rÖ ˆnØx¨ßÚÚ¯~ºnt¹ÈOÛ|X j›ù(˜‡!&8DÌI§7Œ“Šgóñ`hPXµsñ ¹Ïè³c ²r9Ò¸Â9ßÄÎÆs¹kKÙ$ÏX½á{ñÄtÚîsÿš„ ‡áN˜@‰)F›gÞhÅJ‹ýfØòŒ2R”#2Ïè Eë7mg¨È˜üËÊc<íC‘H’Ñ“õHš§ÞŽ¯Â¾Ñ”Ý¡Ù•+_wõñèúåÏß<ýk¦Àw=¾{ñ·Q §ÖÚAŒÉ¾&¹Œ¬H)É3ÿBðÓ/Wão Î ãNL‡@êšø‚›Šžy†oø§^ÅZ£b¿/‹†iÄs¤å³ÁÄ„Ù ü–~!ÝuŠJ`?ÒѺþ`àÆ´/S)3ñ AÂý¹ë[G…«gOÇlWr8F>×M'1Ò%W<£l¤ Æ?màcÈ)^¨KÊE™eJZõŽ¸àz­žƒæ:2»:pƒ³ò§‹$èlùüÀ%þM ßâ(=Dxì*£N)ÁÔ ¦H§3_'ò“ø— ºcˆJmY¤íí”$Î/1‚+nQù; ub _ÒÇ*%ì5;ßËpÚÛÂŽ6BÏt õ͇ÇÝéƒ%ÎPgúHNù"ÚIꇠ ö j‚·M½åÑ¢Æ|zRÌÙÈ[V¹çó]b€4åê°,DZ˜lù? *ïßã°iú¥½‡_£­Wm„Ëô3þH’êäœYÞpßð³_UZžÀ€J9-$hÒ<Á'±4JSžÿLûŽ0iÁö>‹Çü%¹ÓÂü¬˜ÿk<*fÇ O•Ù06˜£ÏÔ᫦“‹ìd¡ˆò°/•§ïU×÷:dïéí°îÿß;þ$ ÉCŽÿ§¾H¾ø÷¿ñIxO„M,=æ",vRèaØ|Ü3k£ 8Û‰Šm¤ÕW8f¨s¢D3¡þ|Þ3#7PZµ<<ñË:‘7lù¡dÈõÅÿžÄ(óD}=·Æb&¤F¸}ÈûS—kºÞ½äéW˜¹èãÞtœEÉI»—þˆ—s ÍC*‘p˜É¿îrlÇiùøÑñ±&q“<¡ªÿ+.*ɣءØ#èÃ{dCøƒü÷«761&-ÙùÆRZ¸Þ Ãh]oH¼ÎJó¦ ÃÀñÃoÿè‹ø>aãàmÓHYwê=þ†,Žš`7¾Nð¯G±tÙqÄ5 ÖzÐãSYødÃïsþu&:ÿÿy"Ö)?Æðy”e’Àf6X—ûQMõ endstream endobj 3469 0 obj << /Length 2888 /Filter /FlateDecode >> stream xÚµZÝsÛ8Ï_¡G{¦fù-©7¹´›vÝiÓ\’Þ̶ÝÅVbÍÉRV’›æþúJ–lå«ÙëCI$@‚À\ÿˆ«¤…ÿÅkAÃI±¤qûï©Pfrxê¶zt~ð׊ãT¤™Š;•RÁb}ðíO,aìCÀa$ nÜÌu ™Å“äÁÙÁ¿H=ƒ¨(d<2Cõœ½ýýË)íâf*ø$©ioËô;ç²H—¸áW@‹õä4]né·̤ŠY,t0œÅ&&nUvµjf+:&u¶L©çtVQQË´¨S?éîEeAm³ò„Si&I•%yZ)©ër1“,iZ†M¹³ìl±Út²××yºN‹ÆÜYøðs¸VêIVS‹K6Ž9~]Ü’mhÞS­™ä¦µO_>ŒYâL‚ÁúYËM•WÄÔí;u™ÿ˜ 3i?›äÊwÑ–°Ý³%6ÙHu»^$EÇÓ÷.<‹Mݬ×iyÿ$³8fÚ„CÜu iYwÎóx[ÔþU ²+üŠ'7Y³òtwFÛÝv··‹cº:\v1•|²Éò%ÍK¨ílš ­¿¨·Œ³|ðÒYñ"EµX39K[©éÂ-%ã¥ù]JÕŠá}C‘Rí²ôƒë²J©·L›$Ëk¶1\šÆÌ„wýEXš¿ûüžD’£@ÑŠèûW#xÄ„èLò•_QÀÖ é tÕô†U§þl­ÊhÔ3¿{ùVI_Ý©!Brí"M!g|ÚÇJ†LP[¡Y(ÄÓÀr NDœqMœŒð{<9:ý4æ×Ì¡è©ÚpöSUi} PW#;ÓÆ„šúv š«²^§ÕzÓxÕâxyI­³nœ±ƒ}8ÖÝ~,³z±© ëÎÌmÄ$œaÑ)âËÕy-É8Þ¢Jˆ×ÃÑXh¬3$¢¼-‹¦*sÝ57É™ÀL›hr¾Buû'tüý@_ÚÂ"ŽàÙG:)’ü¶Îê]w¨[/Íó•u“ú‘‹[j) @§Ø¬SP}’û„MYeÿíY·ÓÔÏEzÝÐ÷CÔ‘õ׊û˜U6´{ –‹Å¦z2ü¢#|9>s°I+œsùG#×é8Iþ€#(Àœ¨ç*4p½ùf]Ph@@“£ÈöX ¾o½¡ôñ‹î!kˆzY•kêù¨izᄬ’Ú€í‡8©Bù˜hmû)zšs+©WÞ&#Í÷Õ팸P;7³tJÂä;Ðvëf¿Œ´ƒy}þ8¦Á,ûÑEb,,PñØ¥$= ¿Í*¢C𨲟ԇ4bgAÊ‘­wBgæñ+¹ÄÌzÿ¤³± ºF±(Tí¬!kg)Œpç0¯ËÁ¾jŸ*èˆi½“+x y^_CºÑ¿KgØC'ÄÈs¢ô¦ò9wxá§WÔBÚQe.Åíñ褂Ý긪Ó•¸î}9š.Çpu‡­AÚ ó7 !`˜Ú—„>8<æSZy›c†<ŠO¼v‰Æ=+$Su •Š¸;S\ð~¦tv>©¯¶͈õ(رxdÌ„î";Äó´"õ,·X¾˜‘éˆÑñÓ¤¸,¶Óݶ¶4fò@Z Á-<äî÷jïü“£4CŠ¥þ^ÍùTšJÎz'XCÎÓ¬@˜*µû¢ìÜÅoÑ>3_–ȼîªt‘!$w@I õ´¶dÀ1wf0<Ó€ön³ö#8@ÂÑÏ¥ÔϸvÓzF/¸ôX m™ÕvD?;¾ÓN„JšIµ²Y+ýÐû*¸éδl5Å7 ¬GÔ·¾ƒ<Œ²>‚ºÓáº*¯À°è#ËóMÝT ¥.HIü¬"ÚE9¥_æÎŽñÀÊ!*„úÁÀ* ûï\¯ô[ÜsŸ±1,V1ýöùË›GPÞ’NNÞÎÏæŸGäÌd¦ÊwjY89ê®æŒW>ƒC -¼¿p"™ *tœöãôýAðÍ-y—]mÚ*Ð \ ¤ÐÃ8¢6CñçÓˆÓK VºÚNÐæAÁÎÌð{ WA=W¶k€°È7K—Q©”üèî*_…H‹vÙ)n}]²Õ]LI]•‹œ?ÌI¦ØûÜ!0ZÕe{ëÍúºÞOD5¸†Žm " ™yb":†-"âd„÷U0ÛÍbôLš³Ð Î4¢ÅÌ# lðÊÁ|B®«åÎåâ@ t—š=¯`†¬P™ˆ àx%%œÀ>Cc"Š€ 22  Bâ²lÆmÀÂÎz·‰VˆGI\^¤•pöè(SÙV£Yž8´¥áEâðçd Ñ¿ÜwgÃŽZŒæs`¬Ê>dO¸Á¤Ÿ¯ ŸAê¹ÛžTȬéYÁ,‚€|¾jK0F…»ùTÖdI¾­)ã¶Z¡®‡R(+pývÐçk0É9ž›íF p§â¶4oc$Œƒâ+"uÈŽ?²ÄK£‰˜BÂê—c* ¯·Y5ìdÿ,‡œ:“…?ã,x %N&ö1p~’(: ÁD`D6ØFhŸ(Ü=ßP÷€ ÄŸßìf½;“UÔE¸×#ÛÁNßP<[oÍJù*l› õS¥É’’Ô%Ùîa ‚¿a\Æ÷€U‰à)#IÏè«‘‡Ä.õ­iàøÑ¿¾ Êü´¥}x{ìi‡žB„ÓßÏ0¯Ý%wbz¥.|e^Øö±ÍQ‹Žè¹IÉX…ˆ¶å²¦·! %€i]—ø’Œ£è=¶v°2z–Ùíûξ Êm/"¿¶øl*Hî Ëo§Ö¸Ÿ5ýÇÚj`ô€øX¦å£ÿÿø\‘tÂÌ_e/ølXËCËÔZ¦  r‘4éN·Lš„z.Æ6;×]Au×;mVÔMR,ÒaÖ {`»;Ù^mê_n¶Uå°Þ¨ 0k;35~F¿Ø†ÒÍô!…ßç3¹ýÆŒèòÊn¼{ë¿h~EÍu¿Ù à[¬Xé&„ÔmÎ%}ÙÏ;ï…;RŠˆÿÙ$hÍB¬ƒF„>§†Û±åZ>Ñ-¯jdÏJè23Õ³#¨aGäA¿ A†PûÙnB,憤ÊÇó~÷Ø¿‰»™UµJŸ™ô¾?¢¡"–Oľ®!OÑ6‚`Ihû\0¦êC¿M1øIŽIƒÏÆ,Ò~Ú?ö%(H`ð¥‚h{!O»Ìxx™|äö$])ä-|xò¸?ÙÓ¬OQö& µ¿{¨öD>Z?;õºµÌT²@*å¥Üto¥›Ü»ÁÊW ô;99s‹øG}0ì½rsp¸ïÚ§Q>]×\µ.: #îñiáx«‹ØW\#”½)Ç_G&ј¤²½ý)í5³Ñ9z0GŽM14æq$qÏfÄ`Ê}‚<3=œ":_vƒ÷°‘ƒýÚ±)j i&îÙ°ÝÍ€ÚjRìí½Žìîx”{> stream xÚÝ\YsÛF~ׯàËnÀªp2÷‘ª<(–ìØ%+Q•ÝdóÀÈ´ÍŠ®ˆTe“_¿_Ï@ E€w•¼ $ØÓÓw÷4ÈGG|ôb¯]¿î}õ\Ë‘eÁ)?š~ ©™zdy`F‡ÑôýèÇâÝX(ScÔÅÛ8Ñød?Î_š¾úê¹ `J±`=VŠP^­.Niˆ³wc«ŠúÕÞátï×=çøHŒ„Ì[1pÚÎ.ö~ü‰ÞãËW#ÎTð£ßâ£#Éx˜Nöþ‘6ÓZ_x…Í´÷rHkÿ“†}B BEG4¦]´H21žq=š8|’`¼O$~9Qø%fG4‹Ÿ=«gÓñÄpS¼’aˆ³~4Á.œm4O‚€Ù §t{@³Ãi ãÎT¤ýb<A¸pY\ÓE‹t÷è8W0\¤)>ÑÅã™}–0‡ÅKrQ¼&"¡'dqÛº»N—eF‚b„7Þ0¯ú B E ¬*%a™V^%tnZÈqÿ(¢9Î\hm:6ªø×Ø\a–£’” p+*ý›>ž8OT%EÂpZÏÞÑSçI¶sЖžZ™.‚²¶$Î -;¥á¸ÄÇ’t»@ØŠñÄ Cô‘bÓüš¾ÈñR*ÒÄ0ºRY&¼l£{—ŸÅñ&Ç&0•qòÂ=MҌًzv¼ÁžAqùàxx"ž¦9Â_ Ø|¯Àº Žî„”…Ï*žfB—F$àÏÆÎÂB9¥Ãì('DÖUÝY׉#‰›8²@÷ÅÅ &5˜ŒkýäÅ*抠@UÄÀòoÊåi>%’¸R¸…ñ‘^&ÒKGJÅ‘¾ˆ•È›dÁ:†»&Ë –óâ`þaq9OóYºœ]]\Ü^.Îf««›ôɇj²úT>z=;ûeöqÎr´„]p­¥Ö…[”2–3T:À@A"µaÁ÷£­‘LÃœ(ç}N¸ákÿ6–ŽƒâlÈ£Ò2 !xßÀ÷@]áÚ$¹6™“°;VCà,á^•RmœŸÑºoix†ŒIàLp; ’hרö}Á1 G4äÄLà×Z„59óòr±ZÌÎTÂv™®‹ËåjvyV~zõ!/hÑÙóÜZ6Òå´ÙÙÄwñÇlµ¸*W"õYþ~‘n¾Iþeºþ¶X}*gW7¿,.?¦›OWX¥X®îÔê3ˆ:<”!Dv̻͢Nîø$¼œØâ[ RqcB5­s`R5œ*ç™Ý#Õ#"EcN0zDÀ†óa"àføºÏ=Üsˆ1B C´Q4¬/xÚ’´L;ÙwKŽV ³%WðØP(­Èãa€[0@°Ü’ÈyLé˜Yó Ûý%"5Qg#cÁ)Ä¢ñ´ž“¥ù Å¥ï"—~G>Ñu²äƒ~#]Ð#<Öõ³¬’9•.&Rò;³Ñ"ügÊŠµÀ"™ ¦½¾¹úù|^™ÊòÔÖìÓÕrugŒðìÙ|¹¬ o¬-ÛVÆ´%îߺây†1w.B;Þ_æe–Âp¢{Š¬ûɬSp6‚âÒm–Y¸à×e¨O1†>ˆñX†šr¾:X›GZüš¡E`ÈÀ«Ç­gŠ˜èb¥“µTOÇÈZ¾£ápì-â±hØÄÀµÁãú™}šäØâáÖ]›-B«Ânĵ÷M0‚l£dë¬ &ÏqV¤]&«ô(n×*æ4“f(nâ¶OÔ\·D6ÀÂýõ(k-¤ÊBY€âþÊzÊZ†6Ð؈VŽ½?<¥AP……âa ñ‹) ›ªÊô²45… ˜(†¡@ ±™BeöÊ,“’,›Ý°3B{pÅ»ûuþÂòñJ8­ÛdÕ•#†±ú©14Ò1évÛÃ^ÊySbúò¼?ò5Ï· ÿWâ¹–±\;ÏJ¸‡Ì~,¡lÃ8_d3ši-ÁØ8¤3j;Æ;2AKâ‰1Z||F”äîÁ|ç˜Rïh@²aƒë©Ü _)÷6ä#{$¤“ÔiŠ\¬¦Ô‹ƒÃ™ÀHG©»+°¦’éÄév:¸üS–)GšÒ^eûÿ&Ê;’ªÄ(mb!׸N© ân*- €Ò<&m¯Ý‚)¤7Öµ‹Í Ym÷Uí²ênê둯ÁTEÄšýˆ,€Ž  X2QdÒ؆àÒÉ[Ú•âž$H*Ûis^1§Ä ›óÏë­›»xˆ:ðvoÊØÝ0ÄÞE¹}okvmC¸ÛdƤ’æ†;ǜБÂL´”M»Fg¼ÜÊ'œ:[;Û-C,Õ ®ÎÈaÔÊTÒ>Þ[ÖÎRÚ¨‰²ò?“€I¢áñsݤ®š¾r.tR®áÙ®â.æ\[·ÅŠü«ÚìU½Œî~“8bÁÍV·vaš<ÚqvU|6;?ob´Ó–Wç·ñtâ3,(ç™E®?@Ñ™@Q!¯ãÁBŒ2쟴è¬gV›!bX¥µ}Lѹ_XæÖÚ»T~eÇÊ/`c\€„øõK'H2‚ÒîÁ‘ä5µô`Wr•âôÇקݕũÌÍrUaH*¿ÚÿÑXSÏE®(T£&,`ÂhÏ71q´÷r[QØÁú¶<Ú÷cG‡òŽz¡âô¦ö­Â}?eS× ¬¬‚;¤æ)˯ƒ"Ç›Lpj+oà®I@‚¤_#$¸ÿÀ]óDhøè‰Í%bK fRêÜQ3ë!ÒHÃýÄ8 g®d$IL%#mÖ›ÂñbÖ¡¤8ß‹ŒŽj:æ°”á¶rƦncš½M·™ŒQºêE €pAô"ÔÖ{=1,üª”mb€$î¦4œŽOŸ‘g…Åý:C˜z“ú&¤ø³a,¹2ƒH‰â8|Ò"LÔ(Há$…ˆÂBûðBˆ¼:QØ<¥aAøN„¢EÁ€€·P;Šš;aWûa¡© ¤åD}@|½èŽE®“ÏÇþÂÆ›®AXU¯è¼›õŠ&\©Ô•[+ ªLåJ•NÝëVÍ#8ë% ‚4®/¥ƒ.‘ éÏKIE-Úl*ïÄ…Ð%DD’Ž{æ*Ê:wæ­©ykomÅ[%}m•gÞ´èG%8j®ú%åc;Y£Ô‹d”ú@(RŸ}”F©+%`cl£Ôu7›R“]’ìb”vçem”vçem”úó²6JM b”ú3·4J;òV‡ºS9DÞ¶û’ï_o^½`*ýÑ8Å(²ÇÔöïëLÎÐ9~lî1ÏÖ,íªaj<'U 'µwÍ–iòó|^~4[.ç?ŸÏß?Ôödz¾O©Ä=_Š²¼¿HÏ—o×aZé=5è;³)½_¯B{mcv/óUhIÕ§mUhäà:´«ÐFã‹Ü›?fF!iün>’9 DYz'¨î¢»c‘«©Ñ;m:bã„©^±•quk#S?Ow·é²J.¸â2WÙ0YdJÃEJIåà¢Õ ”¢:‹ mJ`ørÁm:³î³í7º×þc;Œdÿ†*;k’òÜkˆGlwÁsî°í¡( ]¼Î»Ì ˆÐÜ8ßFq§cï×½ßtl#:Û8zÄ ±ÝxŒ`¶ï6ÚD°ñ ?²ÉZ„Š¥Tx×úäñ¿Y${ý endstream endobj 3425 0 obj << /Type /ObjStm /N 100 /First 980 /Length 2156 /Filter /FlateDecode >> stream xÚ½Z]o\7}Ÿ_¡ÇôE#R$%-‚M²nSdÝÀöÃn“<¸î416°Ýþúj<ŽÝù°à½5Z´¼wxÅ#‰<$%ç\9¤sÍX]ÀÚ\ÀSc,(› %˜‘ 5”Ö•[hÙß´(™¿j„ͲL9÷w\L\’@ÚGÅ÷T¸¸dªõw%Pk5dI˜²¸dŠºT3“K’Ù R œ ß %Hêß–äßâM.eH0Éç'ý ØPÌ lXÎ.Á†•ælVØ Ø(Åí2lTò/ƒ;faØhÉí2l4u»Œÿ¤ävT’¸]Æ ´œ9”³ô™»¡J>(¹^‚¡¢ÝTªï‚`‰1’ÿZ!˜È0Q‡ÌxG¾c’KV‡¹ˆï $ ¢}Ø 1ëïZêȃTÁj°™¿KËÝ&^µê8FÉa‰$x‚ÏA勞–RÕ ` ŽR$huoÑ ­CÂ"Xª]‚19`LDz¸&`ê›løM}ª…Ýëò,Œ`}¢ØR+ÉÇp»±Ô‚--a Jj]‚ŸrîshŠ#Ç K&ß/UHæz°U¤$Ìe¹RJ÷¸u©Ý'ÌBMÉ—¿¤P)».á[…WðÏàTÙÜà×Lîï°°€YT•þ¿jßßRCµŽfªùh¾ໃ@²î*j%ÿ Y«Ç¢¸µÖ1a¨Š˜=>›ýïË"Ì¿;;;¿šÍ¯¹êÏoNÏþ;›¿8¿øuqñ.!îÓ‡ùó×ó—ï¨?Ìæ‹“«ð>nŠm‰æ®¤¡‰Å‰ðh}ž?óÃ0ÿþüè<Ì_…gûß„o¿áß ŒK‰­Éʸ&Š›»¬žþ±8<ùt}1 °WD˜ÇäXÄ¢zØ(G~* Íè܇h °¤FxФ¨E6¢x½¿÷Óûgüþ› 7$Á <±´˜Ù¥FvŠk)6~:,1yÐ3f¯Ý@`Ñä¾úd(Ľ¹Áj,cÐf4ó ç¶Ù3^¿Ü?zóþM‰ƒ‰¢öD+h”•"XñÜÊŽÕ˜aOX‘3± ÎŽd-2ªÎ-¶\w­Æ¤»B"ߢàlÑi…LŠ¢€'‘™ÀHEÔà±`~æ ÏÝâR''ÅvÜÚw»^ßí²ÿãË íSO¡lAý×)ÕZ4$7”$?UŒ®hÓ½%Vw/#Ücmþ N™)Åj ÓH¨×P\E„ª{ Õ͉ìÀWãû÷ÏlR ªŠòˆÆÙ)‹¤ˆUÁcË;+ÝÇñ ƒIÊý ÌÿýŸŸCCF@aWP°]þüa«"z‹è¥©U_‹aí\â°²Ö†åm£ÚE¢¢:ÔFÊ3Ô·ƒÚ9¢"A[+J÷A키‹¢~P[5Ž_º‰1m4u¨FÕvô¦nL­U´á±¹€eꨛ0¡ˆ]BÉ“xX+!²µsð¨68œó_6gïüìªÇî:3ïvûg{^¨Ý< Ç3´¬7hÌ°Ã7jÞBê̓w‘%¯ÔÐo–Õhè´,GƒÙùÛ‹ó“Ãh%Ìß¾Ú ó£ÅïWáÃ}¦z{üq1›¿ºÅÙÕ¥7“NONH—ç×'‹ËeßÚßýkñëéñ‹óßCç0Ã,–uÔÛã |rÓ;ÿ]Âpo¡Oï »à ô@7/'ýa¢œ‚Hg s…G ¥Q-èåAcYô·Ó׋ÈRyɱ¡s_¡@Ós©;Q\âËÓó³¨S6Gˆæò†x¾÷¶~†MX‹£-ò#¨[&= ì‰L٠ͣ 'GÑ9žýÌQä¶y1®Y­êø¼–c¹ æØ»Š„ú¦O»ãçh6Yíg‰·‹“„ÜPÁË<ž$ê:Id{4IøñÔ’ ²¬’²”XPW*þo~R£Ò ]Ï…Ÿ,Ñs-Ïãn`xB6cÂ`D£{zÑèGsâhi¨…𬛋î/ÇÇ/Ž¿|ŠÈqøg=rŒƒ»ŠÇÁ&m/¬Pw j{ûÏ- ¶Dͽ@¹B÷sóÔIWy=ž4=>žd•be•b…WÂ*Ôdj¢+ÁVBY uÒ(DG¡pwD94Ö]$–~d'zˆ~Q±Ñ”§2‚â’Ñr–ØüTH[l~/jL´ó$B'=2Žî€·8À¥ÚNSžC„s)_Í7t¾~U³ËüþÏ’QÊt| “EJÌJûLQýJme_œŠt·ý¾9š²*©±yvçèF·E XšHwž¤¿å,Æ(Š–~BhðDBÓFº¹FÛ?øápÊS9LÙñ'‰ì7»üqðér-) f£»Šg£Úठj‹YTÖ†s:-O˜»,ù…ßz"{|î*r—Žå.1ZÏ]«>QeÊäÃ~¾b~-Ž0>?ò+Æ~;ó–«‘;É¥Ñÿãç)Ð],è†(¡ôû3ÙJî¡oŠÜr3qrzµˆ¿->ùG²uw·Qw·Mg`~‹gƒÚ´¼aÜâ‘÷\ížGÞó»{îyÇ‹í„ÖÖÐÊãÐVU’­ª$[UIf“VÔ†2¤õ:õË*^žË @ëÎÆxÊÆDÁ3þ÷põ[p§~î7ï[¯Ê~üéÅ”U¡BPæè#ÀºÿåãyË=À¤ö™Æÿö%JÔæÄ‹ÉÿXa@«ƒxWñ6µ—>¤|›HR4Öãø¡áHØŽf•¯}Ï|B]N”TŠ®ÇóòÌs<žï®I‘Á}¹«x›áá›OÛ7k{ µQíÔЋk£X-£ÚÚrÄø£ÚèÎ,k—Ò/ÓµOÚ¸6Årw½ÿüù*| endstream endobj 3537 0 obj << /Length 1171 /Filter /FlateDecode >> stream xÚÍWKsÛ6¾ëWàHÎDÞ¦Ó™:©:ã8®­ôâä@K´ÅItH*Nþ}À’%%Ú“ÜêƒXì.öñíbä0ònƾYÌ^ŸIG,uÆ(²¸'\h*´$ÆjÊ%'‹¹MòÝ* Í’§"Òê®ÍË]\·kd6Õfß–²¯ÿºùÌ4+áœß#)_!q9ri:çGÏ4M¿,Þ¿>S‚pNÖÂ{ÌÈ\d”ôNh1Æ’t¥ØÛb×書}¬Sn!àF{£€9æ8š 6”LŠ”ëä{¾}Üøh•JªûxG²ªËTèä›+êÈk«(ºo tœ 3Í2ꘀ ÃE>}¸º™ðG8Ê,ï¤î+´1MØU’ ¦;…??~zsqšÎ äãêúôíùÍùÇˉk¬…²»Në±éiâ]eãx„ˆi€-À£à#Õ¤öÀê6×ïfä6È•ûºˆ:U"á¶PV¨¢VÔ¹ P\n£'‹€.i“e¾Ù”»¿qIS|Ý»%ÿ<·Ü¦<)7y÷!ÿpÞ®ó6rbú uó¦)¶ë* `àh÷g‚¥›ý]S,ú ä1þ]*X²GWv•OæÓÈ—¬«¦Ùà’* „Ð]ÌE]ä+*“¨ÀÔÀaª˜ËjûXí<Ãt¡PÕb*°ÌÀ‹efrÐùaÒR%Ü8«¬k•œ¿½\\øÁ¥»Á¥“í¾D¶qsWDÁ¦hã"  xÜâ¬ìÝÕhþ€¹¼­Ëe—Ã`õÿòÈ[ç)±ÑP*ª6?¶ÛÂk£m½_¶ÐX ) Ë¼Äîƒeã(û)݆«ªy7@3¸ô=®ûa_—ëv¾î÷M¹Â9¦‡óFÇ>ÐÚÔ0ƒC¸s!ƒ|c5ÅOF{œ80'L‹ÐUTrhóNt’ŒM¸˜Qn²n¶A8ü%©œô5žñžËð)™q,·L†‚1k>œ¾Ôf¡å3‡õúm" éo—†)ù_þüR<ý«yf/çy²Šê>É/ ዛ“C²ìQŠ½ÄÔuÒPÉì¯Ýîï£ÊÌ »{<,¥–ðÄÐ?YKã°˜vTÌ4Uþãh–¡=Ö÷-< ¤ŒÌ?¦ ³p„gc‹Ýå[pœÂ ƒ>:ˆ¾Oh˜g5ÄŠåF© šÃÞ†q2ñä˜Kn¨r€, ¹’é¬ö<‡ãfTƒoÈÝã¾}j;E†:)ï§ 7Ìã»qбQº~Ç,sÌâv‚ŸX*’ìY‰Ô9„ïÏ95»Å œ~!Ÿ?Ï O\&^ò‹ã8{¬·Ñëšž%(›‚D_'x *õ?üõ1x>h+h?æÒœ̰e¬éÀãé_}yê endstream endobj 3542 0 obj << /Length 3495 /Filter /FlateDecode >> stream xÚÝ\[sã¶~÷¯ÐKj!¸_2ÓÇönœñœ´Mó ØÚ&¶ìXò¤Û_ßï$-Ê,‰ÜŒ³/ D‘‡Î yïC÷^ïñ¥ã7ý¯^iÙ³,8å{Ã÷=!53B÷¬ÌpÝ^õ~,NûB™â ­.ÞÅþë…3û±ÿ¦ÿÓð»¯^©°@L)¬Ç“"•7}«‹ jbï´oUqNwí ÷~Û¸Ž÷DOxÁ¼U‘.oö~ü‰÷®ðçw=ÎTð½ßã¥7=Éxè]÷Î÷þ‘Óx¾ð ƒiŽåˆžýOjö‰Š]œPs”FÑ€d`<Ã݇3‰Æq qç@áNôN¨ÏÔ½a`¸)Þöƒdhb/’ï 0 g›À†( wBÍý<¤ÞQZø3´_ô"ˆâ.‹;:¨b’~½;Î iŠ_èàqCfœ%Ínù’\WàD$ö„,¿îÒa–„ ð&8æ‚j%Á0¶ˆ” ¥$ÌÒ“ç‰ûs—`Üošã`®Ú°oTñ¯¾!¹B/‡’” t+”þà ïœ'TI‘Ð\Ô½Sjrjâ<ɶñyÙÏ™.’²²çœ;¤æ¬äÇ’t»@ÜŠþÀ C3è#bhSÿŽþÈÍ¥T¤‰¡ v¥²LxÙd÷.>~ÛûÜ4aR÷!/ÜÃ$Íè½®{g9áÖL›zÚ ç óû%¡b¢ÖÓ­xÜ[µÂÆÿ•…îhŽ¿UH½!õ¾§Þ>õpmH—:N<áìS µŽ6d M; µeÖ…HÊšÚ22‚`-‡YcÓ°‚}gÁ§£» 0#ç@=:€#¥€ë©D[Á¤†:żo'ÒVEˆˆ”õºž/<þmùxêiž\©Âø8‰&N¢ŽÓ[ú# }‚…/‚ç+΋ÃñûÉtÜXôGépy{só0\Žæ·÷éÌûª3ÿ¥¼ôntùëèÃ8‡¥Á”•éYË (J=ÈS ÅSЃûu;pd&H9Ê( â¿ô%Dù / "ˆ y}êC4íßáaRà~%¹_™Ì †¬ºàYòÀ”RMžè¹ï¨y“šŒÙâLpÛ  d—Pû¡æàŒšjsr&p·!'hû³_—„éa:ûxs3žßO.+Á»zN¢v(‘sÙ‰@i6¾F ¸‡_ Î5ÄøËHK‚d­/x5Л9о½Í6¿ßÞÿ:™~ødðH˸í0Dñ*xH»NûŠl2.X÷ ±<ÇÓÉ|2ºžü¯2`ÓtœLgóÑô²<{û~'ãµ;–Ú(»Áö È5X"üB9¶øTÀ2L¨Å 0©"9Î3£Ç¼…ê‘ "%³Í rçŠÈSÔÙÕa_p ©½¨ûän©Nñléè((yD_,„nYô!Hvpˆ‹‘í¬°DJϘ,úàάô¶Hg˜²â9wû(÷·?_oJi.ýûKm\{9žÍ*ÊxMA6N6¼0‚ëŠW™H`Dh†ù«ç¼ìS~¸K{‹ ½ì#ÒÂFR¤VÊ>üö›2‡¡H Í!Â%)‘=DS2[‡xãˆÅo,TWW—1zž)bÖ£‹UP+&kñö‘Ž}KÍQß[Dq1‘FƆË©ôY}Í>õsÓ⠸洭 CJb…?UsdFÉ5WY5çn‘¬H£LÖm£Ù®tM#¹“º]#R\¯›mŸÐ\¶I6°¦søLE² ÍíYtkÕ„¬¢¤PQíÍðO´ žRVªiª’iª  ÷=5ûôó,[LÒˆ˜_°f:åV%Ú‚ $Btm4Øíj+Ð>\O¤„’$Ú¸0ðnûýÀq}jU)¯ <ý1¤fU%N™VΧVm£ßíBi@JØ5Jƒþ! cCç´êœ‘Ò;ŽÄf´ëd$^2¤“ÏD»§êi.þ† Ø$‚Õ4ëVyÁE¿\¸& šº‘a Ž–$BǺI‚Žu³@¦'Öͬ¯dÂúP[*“z•¥"=×:]¾ è°ÉF˜—†9gZv„9¼ \ƒ9—Ù $B2aB'œ . FŽ¢zœÄ6ªJ•±8éWEc¹NX2”ËÉež*[ .6RWJøõ “‰¬×t#9´taäÚ"ÄÕ¾¥æœÂ·#óOÝ0u¶Æ>ϼ#“)tr“™V–i¹à ‹‘­±·ÛEË©"" ¡™öí°§…¤hDJz±£ãµã—˜‘ãtHƒ è}Iu{Ï«Xó‚Ð ZÕiM%l#xJ88xÛÅà•ÌÛðüàs©Âúò4VÈ "âUkä ÎÕZË!·ðÇÝÈ!H)!v7| A´0Ž›(¹:¡cÞ„Ïx¢1£ˆÓ»˜g¢¤´Ø:ÄQºô]0¢s"4YâTÒä˵Æâ>J“÷+¥)È•QQÐÌ+ÛÅ(‚eþÒ(HzM Šüj»d³NÖâÊ™q݈+ÕQÅæqUVý‘kø—.F«¸ƒñÝ`´±(I˜Zãõ6+%GýxŸ#ÁØQ*ÍÛª4ß\K }nVç–ÎïÆ—“÷Ó:Àøz|3ž–ëèÜüT«[ ñ®µ],n%m×™¾(1F"Δ† B´KÖ/ì‡0t¨²çÊÕÖ°írâÁèúº¹BØ\°žÝ^?Ì'·ÓO­áÌu²nH”ŒÛ®Æ5X›“béH¥Sˆ—·ò§4r?ÓEöH”ŒÙdݯöXæ–÷nm³æ&·\sƒþDíJi<·Ý>¤TR JƯÍ}Žû¤Šc T"(^Cw|½7©2ß•§^n5®ÔÁrôe±>·ÔÂZœ€? §x¾j ¿x/Ÿ[Œspejqš~è;ŠiÑ“@©·b?$eÒO|¾MÛ0á²””q7©”åßAAIÉŸ¥]Èåim´n’îV°^O.Ñü ä&mq‰ÅGÄ=ŽèI©sQ"æÕCž¡¾üiŠ(U"’¦‘& ëaQ$,6—²Å ‚9èÖ\ä6ÒŽT¹±QžM»?Ϩ÷.ýÌÔi4ˆ«VX€„£ ³ÐYïu'XX)R6°$ìh†Ô\ôáã¹è=uñu.G²f}+\tc`mpQ°áÊt"#ŠCÜpf—¨Ð‘ârŠÊφÆ¿"t”ÔfU‰v;„qT*b'˜è™˜ðp÷;ÁDo À¦¶ãBÓ6ŸV ¬Jh7È®Ûs‘_ºtÞGn¬Þ:ö’®>"ºå`r9p± F¶p¢u圹Ne*'ªtÚÓµlÐ4»V²@$h_J‹™”ŠDæ£ýLJ÷ªCÀEŸ¶‰ §Qu2µŠR÷]gÖÔ3kÓÌÚjf•ôµABªé›ÅÑM ¬Šnix,ÿ¶2H-¸( R •Aj1ŽÊ mÉÅ:ƒÄ‘¶0H[fAzddWƒ$·2H;Ïä£AÚy& Rë™|4HvcZOmevšYêÚIˆ3küÚò•ã@é5szYBR=FHZ+ο;æëìͬ´‘ÒÔ{à›Ë„“Ÿ JVÕlÒ^ÚÑ,u~ËS£Ùl|óóõøjÝöÛõlÿÀýµÒAA|èb-‘rásÙ^ë}s…»‘ÒÓ"†3«Rúå*¾×6fô2_Å—ê`dT´[2ìäþ(ƒGÑò‰ÝÜ_ R‹Þš‰\ ^‹&J°q"ToiÂƸâ–¶¸N¿ÒažNN.qÅ4WË0Vd œˆ‚ᢠNRÑ‹¹ª œ¨®ÐÀ‰@€ÑËEÚÅ­!-F¯=ãF·½áp©¶‹Ñªã,IÉð«!®&>†ÌRÙ­‚'„qA˜í™[Q¤U$ßdq§¯-ÖJÅ–+^Î Ôt] WÁhóühÓŠWs½«éŠAHpùet}}{9š—®õa6.WV®FóQÆö+Øu݈=ikÚ5ûÔœÔÍ;jê?†éº§†YÃùñÐr»ZZU•†Öj}ËªÒ ZçŒ7Ùn¼r+FsMâEA³&x7jœã¡íþÜ?#ˆp%Bu¢Bx©Â®»Qºà¤ÜŽÒàdi;ŠÓkòÎã&‹;WÈJmGsŸkÃÖ[\³°yzIàlR8Ïæ÷·—rªæû¹èÕ’k˜LçãûéèzÁ= ' P{¸œ?Üg#é~!žÞè—Æw±O¤øº5ÕOö¯ü³¾ÁKÉb¤.ò‰÷þÙ•ü°¸wh˜çJ´gÖ‰ •Í¾2âŒXøʈŽfÒ:ÿ•Î Á”h¹¶/ã—ˆ”%¯âÃãÃßÆþ~lOJv¨ÿïØ’éuËßÑñÛ#få·GšoØYt=ïkú˜¦/nhú®Fùµ)úªÊ Døð_‹Fþj¥F«ãŽÊ=¯&`2Ò^3û5é/Žþ;º¹».OÞÝß~¸ݤ³úC 0s „5GÊVgþo.Þœž×Óüx™¢ŠB­-TO"¢£òXnÔ‚e{úK5¥º:røî⛓£dOÏŽŽÏß½Í> stream xÚ­˜ËŠ7†÷ç)´L6êºI%Á`ð…I ˜Ø‹$ƒ¾œ˜!æœ0pÞ>ilgÆp…d1Luë+•ºººôë¨^¨¨ /Öãÿ(Sâÿ,¬ƤÂÃÂà"(ÆŃZTžï nÅØv0:¦[°—F ¥µÏÒp¡¨t³0¸t„!ŵ‡¡Å‡„aeÈ‚[Ž™c²) ö2û‚GaâEcÑÔg¬š)&g†ÕÂó ÖÂbáÁk,†ÖˆÀ=}yxa“åæË1âRVÁ­G AŒÎátpoá!ˆá‚nË1|F LŠ¬.Äcy ÆÔåÓà ’ˆ¡H?y¤ËæÈ©+¬ÈšHó°pOGC µ"7+Å‹”ÞfQ<©8EXm°â7ÃÄc3¸N_÷‘8¦³«kX`d¸Eˆx*Á냅‰¹–(Ö0 ñⱨ°0`-ŠÊ—G»É¬Þ—:GŒxŸ½/ 8…G”–ÇT-|†GäaÄr[,wÌðˆ·3uy``ŽåÒ$Y¨yòˆâ5¾ nÜù6áðp†ÁRoJ©7ln°æò@õ›-ĈOb Ùˆ[Ë1º„ªÌº‡Ì9¼u1滓“Ýö¤œ!«†oúç²ýòëoø ¨*Þ2_¹<\¿{÷b÷àÁWhkÕGšV¯ƒÓ´Ì:,OsòLÒ¬uRš¦V§fiô²:{š³N”E––J’¦Ý*µ4Ý{¥‘¦Û¨Ìyš*c–6©ìiZ­¢åeiéU4Mó¨‚N¥©ÊLÓ$U%Kë´Š¶“¥G¯øËÒ>*ºYš¦j–¦»Tô©,ݬÆÖ¤­×Ø¡’´Žý=KSm3M‹Ô.iš­ö–¦©×>²´ÌQó4U·4î㞦Ñ}´U’F÷š¦Ñ}FÏÓTÇLÓè>SÒ4ºÏliÝgŽ4ͳçi®diš´$EŽæÙ*ÓWéŽ}2„ªs…D½KŸWåä¤l§PÔPÿ7n§BŠ?\@éB_}¸õM8ÄæØž^_?Û_•³²=}rZ¶çû÷WåÓôÏÿús—o÷»í1BíW—¡_=üwÛÏûËãõÅëýå¦]÷~Ú¿9ùèø¾œntö)/èå¼£»ð øðp8b¶³ÙëYª9ŒÏâ/r·=»~uµ®ãu {G‚ºÃ^ ¥£G…ÀÄé§*¤i7\;°‡+uÏÊöÝñù± õßü~þöúb_û·‘œÿe:¸Æ)©3¶H¼l3BãÁ¢bËlrï*.¯_]Âùüx€¨|{1QqàøTñL¨%Çó}QGwÀU×c§ù|‡ü§Žî–Îí¢ºSG8h„4ÿPTe(}<ª¼a-ÿ­ØL¾,6£Wl·sbœLÞmðSòÄ!ç4MÏßr–ŽJIÓÛMÓ4ÄvëYºAl·™¦!¶»äiÆ6¦]ñµ¤i´Jç4ÝÛtö]âm:OãàDiZÛtš–†m:M3Ž‡3MN’§Ût–¶‰ãaúÛ1ˆíøa)ICl“åiÂ6¦!¶™Ò4Ä6kš†ØŽ‘’tld3Oãà$ibûQ–†Ø–‘íš±­œ¥b[-O㿧iˆm£4 ±¿—%iˆíØp’4Ävü¬›¥qpJïR ±}ßIè~Zû¾Ÿ¦î‡¡Zòˆs~zÏQó»gaœò³¬àŒ»oÿ ÌR endstream endobj 3606 0 obj << /Length 3858 /Filter /FlateDecode >> stream xÚÍ[Ùr[Ç}×W *PeŽf_ì(U¶G.3bD©ô ó–H * i;þúœî¾+0$EqürçÎÅ,==½œîèÉéDO¾{ ›òÛW>óvbŒ*!ØÉ«“‰±AÙà&1eœ™¼z?y;Åïn¶g´ÖÓo–³=ôôø×ùùdzc©\œHùn~v¶XžÎŽ^}qõh\•˜•Ü½pØ4Mï²ÊÁ·ÍNV3“§ç2úcéàÊ$«£§ö{t:íñ’”6 ½‘3¦5BçR¼_-f6L¦fÇ+ùvu!åõåq·Ž~>£³rÖVÖ1"Ëe¼é—Ñ/‹Å¥”§ƒé’K;¤ú«0YÑVµ•—ß=˜¼åvϧ׫fU©é"›Š ÕèÃÃgQO¢*ÉeaY4*ä4A_l‰Ê*Œ´´*Ùn?jí¤Íh´¢bìÚ<íå<ýÏD,Æû9¿ä÷3~‚æ”JÓºà÷S~_­u¶qz Ñsez)ÅBŠ¥ÜÉM¯Póaú ÏSCÌNÁp‡¸Cöܵc©­¤v"µ¹ÔÞI M v‡‡6Lcm2mR`Ëd/áËœ3¥¤÷“]P!+Fí'©I ôäâˆq&2Ÿ¨8–â )ˆS1µµ )–²œŸQ ‰ûæ?—R,¤¸bIóIw¯‰E1ééþ,ÙéëY2ôf¦ô8œí9;ýÍ}¡…$G;—<-Ïsþò‘ß/Y0Ÿ¾zðï$4°›£‚EçU.qòîüÁÛ#=yß¾‡È»’'¿pËsˆ£f†MüCl׈¡6eMä¡bË|pÆ‚,UÛ)ì²BcÙ+sëfeÃÒnÖ›v…„ ËfÖå–ggRë™\´ÝÎœdœŸþ‡ '5cÇM¨FŒ³yú qÞ‘VEìãÙ^aúrV¦›eâ}²iú õˆ¢"¤¨}¨K'-äné4ØŸÛC³&š$ԜԒ¤ OŒcÄjr»šF=§Ø›àOfV2Êû¸Î¬b˜Þ²m„ÊH±bÙþVá’ƒ%h™ô=;¡ì¾­0Âg8? ¾YoLjȌtÆç<ùßyry¯ÙSTÐy`teQ®²mbª\Œ Öc§\4ÎØhˆ‹¦ÎDØÞHL4è³±)B0“VÅÅc⢙>©±Jí=ØgoÂlÊÙg!„U¯g±À×M=­± š"X·dô9C £E`dòÇ4ù‹C9¼í×ÌARh½ `XlÈcÞt¼¤·è­¶“pY‡;v1e¯ÝNÅO3??#¹™iàw_w•XCJÃ^„£Ý ÞksR€‹r§ …J<ü¤HÎxAB›sZ¸˜ÚÞŸ4›·#$°eãv§Tx2°^ ðÊl¡u× !Äø9§xU8]îAÃ0j€GÆô¹aë¹`ÂU‡ Ä€•é¼²¹³x'•)àÖ4‚û‘B>™Á¥ìÓãõÌ%y; ÇaE¢á*¦P¸ ­DÚ1ÚÄCiZÜèÐ9² å5½=®)–Q:ì† hT.kdP¼«}kŽ`ª‚¯kb¤>ß$õ¹.‡@¹“ú%AôLH=…äj™ »ÝúèYFÏEBðLÊI…¯íœ'f@i³ßn¿¼JOJç†QW‚5nóüx—Fë1uÞ‘F¹pOÞ ¹0ÔùdYGP, SÔ€°ðˆb¤:6õ>X‡r›žPh{\ÀpëK±¶æ+áåbÛüô®ñ¾¾ ­•{ó"ö©±J\ôN¢$â…uŸÆ Û›µ? /r!WB šSGð3ŒèQûIjgR«¡JÚ4°¨~ò­’L˜í#©ÕTºï„Ž^ÞV£$b;çâˆ(s'Qųm@Ä|YÑ}@ OeLgº'"lÑ´¯%qúÊ"𦤨fõj ýÐ4Ùuå¥fÇÒ·ï”­i­Á¾»1 Ï+ö*ÀÈÄ2ñ Ø­lg¯`Ï<”ÅPmä0˜}ç¸Ú4ù§§_Ðgw@Ø‹;¿ –´i›•¸èS©ýL hšd)©åÜ ¥‚?oAþ>ïÑïW•k®ÔN€†TÂÙŠk0ÊÐgÊYß¹CIf†ÜˆÎy…ð¹ì†ÄzÞ˜1 +žwÎ4,ùý_¢$²mÌ$üt0«³Èjð=›]g5€ ,Ø‹0ï z€Œj0`¼Èï‚DAQ܈‚7/‰‚èí Uzaµš…4_rÜ‘“6†uAÝ8é°V7:ŸÎQ:óÿDò³Ç’­=‘ÚBjËî·.w«×SžˆkXïcq€[ÉʬQEAoï“î‘ cçLV#w°þA,:™r#¦æD (9’Ú#)Œ|Tƒ&dæ¹ß¦_è3µÁ|}063šÃ¹©sÉÞ¿•>MãáxV&1£ñõr¿qwSënÝ툜 NS&ìvQ²wì™Ñð«0='lÂ0 2«–³Í]Íò2,»êA“ߤÆÇ Ü$D ƒ²Cü‘½¼ÐãÔF·™ë¥—ƒ¬¶8þ·wR“ÏÄ™ÌQå/9‡xLïtä ¦ð¯™.r`DK*&·Õ¹NB OCùÔ™.Ìû‚(ا·šé*˜9ã™×(xÓQð’Þ~ Ç9€©6Qö<–OPg«:“AŽ­+©&â349à@dd Ër!v†Ðžçx èñ®4(sN`œ)*é-3Â.ÏiMws"ë ¤µE›Ñr¢,‡Ï‹is)oÀêcÅFPºç6»[°’q| i|j;뮳 ’’Ç>:— ÑÎîn} L°)€é]0Ž„WG3fÜÉ€Ž¹]j ª[ |4 ¶M7âQI7:9 q$;R!½#’Szï…dëéFµ"趢Qô:" žn$-h|Ž…´‡²·u§&×l÷î:AqQA¤03Q°Æ¸ «%Cç†y»ÔOz(è.uP(Ö¡`±üwo‚¹Ë å.ƒ.Ÿf L‹¦rÁA3€Orn%qcLeHIn’r_HAnÎÇ6¶GüÞö‰Ø{äµ²*ŒO¬²µ´„± F§Ÿ”v”"§á–áÆB* KÇ‘(Ö¡gé›+òex|\M¤ÇÉç5ZG¾ƒ%}v/ÊÍkŒXg[éý ©4£7’l6˜›Í¼O›¹1 –h¨¢+y3çoÌ”ÍäÁšGr¿™xÒ怷ò'0^Šœ™â‚àPÀMüq`6 w ´©ÑU´îtx|«¡(x£!q§5ÌJ'³Û£¿bhµPdm49ðBž›Œ*{›Fš¡ Ï¥“T\“šá<K)®$wEw͵‰”[#g g=Š¹IØ“W!›;‡btb8þ>ªr˜Ú´¦äŸaCŒƒTUâûd‰8ÞÃû™1¾Êf3”E»’BÑe’憄ìH’MKÍ ÍÒšSA÷M"ÙÂ@a<_Àã˹=Ç7¬à@ÁöNr€rè3߶5ØWR›jMïFYÖìi„m áÞñê„ä`GQº±Ý&Ð!1g=Sì.h]Kq%ùŸ×>ÖbqØøäüÖ±xð ¬oÅît±Õ²ÂkЖ•V?`L ?EÅðRË’û¬lòwêHöq #™-Y¶eÓ¦Ò­È› @)-i™bê»H#Ч/Ò\sŸHšû}H£›`Í9È¡—¢Ar ÍÏõW¡³Í¸#`Wº-y,‘ì|p))È ^½ ¼b4]êÁ­¥¬Änš³1åÞIí_R›Kí´C{ìªÅÏFke£Û:€ÆlЊp«¯ÆÏ]ÀÉ÷ (tì²V!øÄÎzŽúv?8ëø&Ìçƈ2[©{ó©É3Ý~O(h>éptÈS¶[3B8¸N E7{ìæ=!F|¬Ÿöþ›Œ‚ùÓ.µ:¨hÖÝ>¸D e¦ô~_Q¤Q XIq.ÅBŠ¥\ä›Kíªë€…}N²±ñÏ|V|íèÑbß6O©ÿ°š§r¾±’b!ÅRp%µ’V„(T“Ë ”R;\é3¾‚âÆ­ÿMMÍt5â`€ýæç¶ò/ÚÐÊÿp„ l3„ ÷P¡á Ò`îOEÅ\dºõ8«[‚\ÊÈUã ë½Ûjý…NuíVë'bAw°~« öÓ×ÿUÍðÁJ»ÍÂ- =r›…[úÇ•v»YxÁ‚òxá¢5Т?3RÌü®øiI‡Œ(êú±hHÜŽ5"èíXC÷ÚŠÛŽ  ¡œ¶"æ°ÕB¼Q)å챧kRkÊ­…ÉôÚÚèäÊ [NkÓ-71ý•·ÚMbÝ{¨åàf;g0è/QÑŒ> stream xÚXQsÛ(~ï¯ðÛµ3±bÙ‰“ôÍu“6½$çIÜÞtz–Ö:@N|¿þV‹,·}’bY¾Ýoù`4Ø Fƒ¯Fîùnùêøêd<ˆO¢ÉÉtG§nòÏ’oAnwÍŸjÝ<ß)+Ÿ#4Ž£‹ø¼´Ì¸i~«Ç*Ù{ûùvá|£ÿ ­¶<…´ù²ªyîTÙ¼¬5@×F’1½È¹o½µÀ4`†l—2í¦ÉœÑ9̯on†óæK4Ñ Â‘Y[¼=>~zzŠH¸—ku\IÀß4/?Èâ/ñd”Ù\íÁs…ó~­ú~Á³-™h¾˜tKP…EL©¹ „ærÓ|-þºœ‰» (˜fÖÍr ‰Uz·?º~}Êx’õ‚T®p¡n Ê™ügt:2 ÊÄñýåìýí%¶ÇÝü8k|ùJqM˜3Á’G©ž¤hm–Æ/KÃt qóý-þÞåÛø{5_ÁDI«ùª´ûI@ÇúŒ-ÐF^Ð ™t™„ƒ´|M04°Ö| `†IÓ² ï²îçž@Ç—â‹:‡{4¶a"¬å Î̶ªÔ¦Ë#©Ðå]ÏVÚLé cˆd}_ºÜìE¡‰÷i49ï–°…[н{Îr0Ví¨¹Ö÷|_®×®ë“kúSK ®£ëÞáW÷ÃÍ—È*!0A&ÌÝJ!&Ììd’i%±$6-y)2l±D3£Ä–¦ÝKÌ”›&Á¨¾¤;ÉrLÀÄ&É -ŽuKz¸žÝºÅaÐZFSdhúÙÁ„½;C€û¬Ÿ!o‚‹ý¢œÑñÄMzç’"vßEá¾O‡'qK>5>H`$ÛïDsæZ?” sUâò},CÑj×XeÄB3ÖÙù¸[iž5 ÝCå´*|8QÐnYpÅ_ÓÁèí0ïrCntlÍU^ 1šÚƒ>ïZ¡ÙÇ|2ƧÓêÓõáKÍ(¨¾•Ù€+³]Ê·4O°hšÓ.ñ¥2…^vÕª£76A5Ì´\¥¾È´ %HÓ²ÑLz²¬úEÉï½T訔1 !¥ $r8àÌ·Y(Ásî§}bºòbçj‡÷v—µÅŸà³_+Üÿþ·L /&ökfh£ÇHå´m4Àž¿¬£†Òk–ªZ7#2F=5M#-10»àlÅŠ¸ \»–ý‚®Á¨ Ž^n]ÚCbmµhdªÙ“…-Uø>j׀铖‰ï8-Šÿ,­pè ÑêsJNÌ© lƒ±ÌÒ.C¿¶ò–&> KææÈ™s)‡JA¹¬¤^n»1I°:Õ»D__çLò¢ØÑIÅ=sM£0ê€TA]¦¦ÊóKg0µ@oÉ“u/bàS¼õž±™Wâ/˜ÛÑuÅ•J»9>Â\Q“Q>%u¡¦èyÍéŠúç@½ibµÄ¬Qõ€­Ò¶W -nŒ¿¨2¦äÖñ”XB˜m˜NÎuøœóo‰r>GZšnvbíIy­H'¢fìpÀ ’R¿8é5ó5?4[`‡oGRfY•¨¦ÔÐBÓR™àÞ€„jg% A¼æÝ;A{ŽñY&Îk–C’ ÔHP- ¶5K|d)ëýÉuoßÂÄ—–$'J÷t/ÄÇ¡ÆÚ²Ÿ± z‡¨:>xÐí'j`I{Jõe YT©!ô¢2t—'“hŸ¸»‰» ™ë7ñùk”ÖüÎ}Ȩ{òû7 Et »5¦'>«£ÚôŠr÷b¥w›Àþún±¬$þyyyý±z‡×÷×Ëý;–Ö¿º]yë&ϱR—$6g<¹¨ ‹êÄ<†´ø-ÃT&­÷Ë„ªéWÿ(pJÑÞ•Ö2Í]×"ÃrTàeî Œ7ˆE™Niº&sè°…|´î+ØjÒv³UJéõâxð¡äB°’¸úI¬VttÀ£¨Ú? R;2gøuKQüÕ!ðÁB‘1 CÅ<ã(î]G¹ÜW¸ÌDq3ü’®LîUéGþÍ Vw¶ãéð†=f)ÓA–ÿmÁ¢"n¦'÷-;ò àÚ?'L÷²f.ê"ïænV<‚Ž:|:¾BÎ\ ÆÓú^ñ|Å1’y:ž4>\Ä!—ËWÿ•ò¾- endstream endobj 3666 0 obj << /Length 3169 /Filter /FlateDecode >> stream xÚ•YI“Û¶¾çWèfªjÄÜ™›F£qäÌV’b×+' I|梀䌕_ÿº±P$EÏøˆ?€Öd?±&±Ô÷zû˯·®5 ÍÈ÷ÝÉv7!¶gÚž3ñCÏ$™l“ÉWã ›Î|Ë2(W…=§5Û5™¬Õ¥ü.(/³´Pc®Ë¦ú§aõ•¬®Š„Ó"US‡ò594üt¥ë<­êòxP“o`(Ë®¦o? 3b™‘IaV4-Ô f·Só?§EÌŠZV–Õ1U×GÎöeª%_§ñòDõÍ3ö=­dyC³sZ¨žû”—UF_dmÛäT© HÆ„Êÿ¹d9Sg}=(ýè‹ê~fL!.‹š§ÏMû¾6냖ìÈËÿ²¸6õÆ61#þÀ44«Ê·Œô©a|¯wßć&ûWÍÜ•\2VŸÅi” œOªF?=®oT{aYyd£Š¡µ>š÷g‘¾0^¥õIÖËZ&Œ?—¼0e]¬>Ð⛲k’œÎH+R·;Ð$O ”–Ö©¥w¡c2VŒƒHú¸p9¥ÐSä)iš©ÝŸi¥MÓî~ÿçýÓ¦o¡ o¡Wªñy¶p{´Vø[Ίø Ðù°nÆÌsv5½l8(ž¶XÊó¦Í¶è®iÊGhžògmÙ¼lŽ³Õ5kys«K÷7º¸Yu«ÆÛÛ­*Ý]?Üéâf»h}(>0ªº™ß®ç£âlæ÷Ûåâw=0ç)*UÛ–5Í.mªbÕ%¯¨9{AGÉãR>Í×ó»»ùõ(z‹d ñuE‚¨ŽùñrGÁ´.ùi 0g£\|)nª ÐYµBÖ1"IÌ8³ÐL‹]ÖRX2 ¯%ÿ6)nÓ‚fzþëÿÊ´¨ê´nê ¬Qú’&Z"Ǭª†k£ÙFNw¤dÓ3§ñÒHõ›rvì:º­ PiŽ ™E¶</×ITköaYT,݈$%é¦92ž²fT‚¿,ÏZ¬–(”–ëÛùB»ÀbµØÎó»ûÕ“lSz²ÕŒ7:¼Ñ6åh™4‹›œÛ²É O2¹ëˆ\· Âb'ÝÊ¢ iõÆÚ¿SÒ³'RHh1k3°´¢šÙ¨$*£÷±£(V÷$QøI˜²æìZ6<ÖuL.m³‰SX4Ý[Pg«›õª«æ;úŠAOÓÆ¿±ŒÖQÍÙÙ®úÞw¡ùìÃ¥lúüO zi•ŸÅSzuÎ÷½0!| H“=!®é¸¾¬ $sˆz®”lÍvOHhà±*œÐ2®_o¨C·\Ó ðSË´u¬¯äïÞŒÉ×™çùÆ"3c¾o²¬TRø]êæyfdÛ0G,óXàxW:1›zVîf1„$'0Tãí4ðÀUA‰é¿ e¸ ¦Kì¾£bð~J,=c¾ŠÕJÕï)ÐuÊÁálb›Äo%‚8m<nZÉ JÔ»‘EÁ•ç)‡´}Wt͈i»>~Ú¾e\fjû4k&Cæ̱ˆéDÑ ·4GÑ ær½‰eZîÅ–éF!~Ú>(ÄFøEß»’ŇrJ<ãeê{†)[lË Í¾áfvd:!,Œ[äyíQó>M !BE¶g¬Å×7æ9R‰Ú>©|ËtIª‹#3qÇ#1­m8ÅÖ¼ÉÀ0‰<Š-U™M HO\°*1¸š.²š¢:Û@ÃÊ+X .–S—I†x¦ëø†^Œ “€m_cá‰O]Ï(cÆ`š°¿K":ü ÈbxõA–¾L#Û(y–Èê¢,öÆȯ§ò«¢Î_–eÇzx~ljo°Ÿëã¾LX– ’‹„—cÓyª˜ìL‰Ü;ÀýÀ0Ä•‚Âê~>u od5 T;2Ø`Ä-èÌrB­ 5œþ‡ø! 3p€Ÿüê¼ Û¶€ð;ne‡ÆB÷V‡˜Ó]­šUóu™ÖŒ6ªu®[›º¦g%ì*FeåPý:ã‚ë`'gGäh…DI5_!ܘ^‹àÍj~/§~µ !Z DkD(µDÿê(À©Ž<€ŠARñHqÌ¢fÐßæÄõÈ_€R(î•E ¸” 9Ø‘=@’ûN(r%’ð{‰$Ç÷ÛÞk¸,W)XÓµt×\wµ¸q`^7ŽëŒàGm§«GÜS~ÞÑ3îÔ²÷B¡vˆ×þé¨^§h«—®¤ž’v‚[#²rÕ¬oú3ۇĄƒ¬‚“|ÛxNYC:ž$€l è¥Æfˆ1βãìäêØyš%e.0p\Î39æ5K§¶…QÙ3²9ƺº•W"C‹ )†F,Q9®ó¡ñZb;îÖ׈õÕw(2t’bR`q-«-Ôö@È`ƒd¬éŒ@~oÄx¼^¨hMe,œ«A‚ˆ@¤l”Û6ŒŽzšOLâº÷Yy<œ*¹#.âBÊwÜ®‹t_¸ÈÚñ¹1ú‰& 6ÖI×Nèœ=È¿Æ:u“¹÷N,¶‹-w,G†Wèí„Whí…Wè ¯0J†WèÖþ‚eí/Xõ-I-MAœ ð%°çwñƒ‚î¹>bë!|Æ2þC Át‡X ÑšŪyÎ #Î ‚ïfµY¼©{½üwtk­ÕwD÷تz;º‡ZO÷Èú.uï©{푳£{<`ç Ö›GiFŸÓLZÀ³á&š­[Ê?ÒwÏ(3ˆ‚C „ãp½ðìÌ :¹í Ó4Ò|ˆf2¦à‚闋ϳ=¬[òJöÉ“Aa~Ž •Šžøt?Ÿ#]û@„OŽÝ,Ïô}çìÇÒO=(˜Óg×%O€Ÿ|W–¸åêŽ+Œ×d§Ÿta £à$è¨4â$AO2$ìíd:¯Ï°w$ÓyŠ!ámʃ¡ùPÝhò å$•qËç¸\É5j‰ awžTjЭ<¥4§{Áƒ85¿××=“U‘É€¨ÉÜU¡\Qô ÙF-’‚P¤)¼¿<ããRÖ€Àã¶÷á_0Th%–WäþK 2î.cÀ¼EâeËòÕ i+.7_Ï7w—PQŒÉ[i «çrKÇ"Èf [ãÚ”ß?ÄüÀ‡@!ïè®þÙBÈùŽÈ;ºê£{@šÜÂGõæAô¼Àzóʼ}š’›ß”^ðÎEÎu-UÏ2ËyYúTN;Q> stream xÚÕZËvã6Ýç+¼kêœC|öNmwúe'}¬îdfÒYÐlñ„"’Jâ|ýÜŠOQ¶³ÊÌF …q UEygwgÞÙÛo<._þæÛïBï,v“0ôÏ>ßž ?pE$ÏÂ¥gŸ·g?;çåþþÐdÅÝBxÎËÅR…‰ói‘xÎêzµP‘ó"‰¿|þðíw* Å®ç+ÌcÆàn—zÓ*Š8ß—®ícVPòTº²Òõ&ÓÅFsßïK׊Eà –Ý§wíÑW)CÑ6¼ÖUž\I»´Ä³%¯j)<7 »¶õ}…—äÒs–?.„z§w¦K·Y蓸‰HPúnâû¶ïÏBþ2Vûy!ö‡†Á‚%öéÚ”ÂYíuÝ”´‹‹00{â ç=k­Yëâp»sËÍi±µíÜå¿B&ë].é¼xóçFç¹.H}haâÀI«4ÏÍ K,Z%þ™‡×ì’¿Êз›á¹~Qѵé<«Ó&+ ;ÅVÛ©óÔÖoiíé¦)«šç\~ª gŸ6U¶0fÍO¢x¼ç›Jj‚ÎWÊ)ÊbY?ìz(]à{z½ñx½˜è·C;Î}y¨èÉÇJX”V›]ÖX«³ë"vCfðTxj†ÔŽc'WùâÙ‹Û—Ù:õßf5–zC&v0úAè^ðl\´kØø´âM’ =bçi¾9äi£± €‰7àÓ"d•± ¶‰Hºa¤ÌøA<³±<4鼯îRŽ¼¶oƒ5¾L,FÖ:=ü K <àgËõCÝØsZ×\¹ÁWcJ€üØ–h æ+otÕ¶|G—‰»|Çݯ˃n›Rl¯aÈ_sû—Í›Ž¼Þ„®¡€Žæ2ô<ç‡Â*m:ïòȺ˜¨áúžÓ]¨¨b¹UfnyTÈh}•˜ËÕÖéÙø"Úgò2ZÁÝͲ¼]nʪÔÌ”÷†"ÍPþHø­Q¬ß¯®lß´Ñp@ ².š¥äYŒÛd_=On¬ µcŒLè|¸KT Å¡!³R~os+‘DY’¤³;!§v$nùS» Ÿà0Ÿ9 å ‡±ÝI¾“¨ršG†æóùæ¢æ™IX­13×ZpïÞÒEÊÖ~ZoÔgCÙYÑ WÝîÂe‰¢Ðì.ÎygÊ=c)fP\?‚[6P›3y‚°vB¨Œì„fÝÁÄNŒä1“*†wqd†‡¤±‰s":—±ß[DpÄD¼ÈðÈ$¢'¨(ˆ-ÑÅ¥"h­¹Rš/ÚAÙ_,²ž d¯¹í$D^$y+ vX h<=× zÚ>SIó;Ä-Ínϼ/¬üÏvåž¼ß.saTLi­0ߧ´¯¡78)¼-TÎœ¨Ú!3+i]¤ìEhÎ|'p¼å)>[*± b–›ójîa´qœß¦¿ýøæœ3 /¼¹ä‚ÀŒ‘Ãìz‡ýæi…°ÁŒnr (ûÜš)÷³©m­UéÒ6påIƹËIÐâüƒ9z6&PR°'z*­Ð{ñó¼‚ø v9ÀÒØÞkbvðþXáíAWûò°ÙYûG ¤0CÍaë.†œ¤ ‹[R†ú»‡›*c…CoöÔQÝàNÍNÛ‡.¾8éM–ùé<°w;•R§Çõ~ÖML"WEÝõ<Ž~uþ4¯FžªpJ«²§U¡B“i ÂÈðȱ‚-m!D³³Oï ÐQ1R`–âVÛ e<웃ÉÐ"V³Bzo ÆìÀ-½+ 6à/ëÕËÖ7Q"vÝ2š-—ÃÆü{—¢õ.®5mÿïY­·Ì€:ç¶5{ï5g§fÒ.RºÊŸÆçŠÅ™3G/x¸þQ˜îKÜ£Ó0]z³Gïáj¸0Å¡…ÝPÔXü:ÍXrÞJ2\yûrÀ†$ÍÓͯ0ƒ-Ë?°üBï÷: qã—0rf*ã> }ÃyUþÅ ßVZ7éaÿòä3Ëð”ó.ÝïSÊ{›;F0ë£ájó‘|/]¢îb-³Cç‚u׈†pJ‹Ù<òÝØï®ÝË•5cŠ´Ý¿Ô ð [{ȶsÁu,Ü0ê°f§ˆ½dtûTéÚø)B:ŸvYž‚ƒîwYú² B7“œò'¢´Ö”›]V±á‘Ÿ“uÖŽ)xÖ½+Ŭɲ¹¬ª¬Ìép›˜ÝHÈ;ÌaÊL·2æÀœ½aÙ{à c·Öà.Ë'hë²)xno=#··ž­ü‘Š˜¨ßÀMâ&­xb]U%³ù žsÆôt¤rÅ.¶ÉÄõi¥ ó;m‚.Û¤63ç¿ù®ͧXùš M<+’>Å wlzÖ=å&”*7ÿI†œø€3cTmø@’ŸïÊŒE«V”„öÔPÃn¸x±úKÓ6Ù›g[NÆꌄïÐw.`Ϲ±Ç‘ê=é`ðñIW‰ó¶mÐEÕæžeÈ?é&kŒ@ÚYºnÒ"Sú\pëO†°)¸âËš® Ö±@Céš•ÏÛN»t0âlØ˨û2¸Þ¤G<‚q<±í5ÚŽSä<és4t䈬;ÃîÈÅÒA45+_¸±RS«šOÜîŽeWNØ=}ËJs<Þø=7Xãqê7i79æd.ôzØ)©Â@Û˜Ö¶‡Qò /“ 6XbÎ@p9°ÖÜŠ”ÕxÖÙæt<ð¾1©¾©R¾ã7÷UyW¥óî¸ôÅEem©ë|ÖvB4ƒ”­™î©”­ïŠ£L™_™ü¾ˆzÐÓû ºÊ#.ñA=âòèNOâNâ÷¨sÂ?ŽÕhŒz›ÊïÚãuD € xle |ÌÀÇÇÀÇøø™À«(ì§ÊxØ\ÇtO‚mÌö÷¹¦*çåHfïBØfC1ª=f9’|d&ß~'òý»,˜.¸÷ÈoÿÛæ+7ôäŒ5™ÄšŒ1'«)bjNó~cRXÄeÿIj’ B2“ üHžxYS¢Â†id6ŸM| õ­®³»Âjv]5·{ –Ö€j+·q:à ï9¸¡jNÑsìÜq÷>©Š¶¦ä²›:KïL rÊšÚ`¾õYè¹ý·Àì×@Ï•^8N¶ÿ#®‰ôúd{›LOâ‰ÿc×÷dŠxJ„q9À_°I¸ùcúžb´‡À¶‰7z‹êX”ÃØ¢n°…šÅ¶¦V¶k³E‡'žmöÿÀÝ”²Ç4‰”Á4 ùhwÂÝŒÁ”ïn¡F˜¶gzÐÜ%Ô$œ®uS¥ñ¢îÕâ¨ú¤v¾áá>³ü.±oM×ÜwêRï÷TÍûÒG‡"U•7ù‰üÚÿ†ƒJ •?øŠ<Ãø4†‰ÏÍò‡&íÞ'Ö…§ò#—×:Û’Wï feÈƹ+’ Òœ¨™…r‚éµÐÑó:T»œ¨i:™ÃìŸñÄ’W `™4yÐÇuê8}JXO¿IÉä$HÕ†Öž€D5NxZÊ\¶ ÉÈ‚D²1H$éA¢ZiUíŸZ@˜ü'ÈàqÕC-ÙÇî4ÎitT€— £Ñ%gÿi ×ó'IŽ¿ñù°;YkrÃêv~X xNj\ð*Tæt…~ëÅ“ä› ¶Jó]u¹ÞÓ’þSJ.Q£o>ó_±-ˆ! endstream endobj 3602 0 obj << /Type /ObjStm /N 100 /First 964 /Length 1340 /Filter /FlateDecode >> stream xÚ¥˜Mo7 †ïû+tl/’¢( 0än ´@ûÖÈ!u¶Ñ`·pl ý÷}©m‚u<‰ødÎø¡È¡(’ÚR{O”Jí#iÅßAiøóàÄÅ\Ä]\(I¤» Išº™0@›pKʲб܄Gª؈R­ä§©PËH¦¾²R2¸ÕÔzq¡À q¡%&÷ÃÝ Ö6xÕ³Lj@²‰)±pu ~‹±KÐ(ЇT U×`…4¦†%V0¡cj`åZÜcå:=Á÷±‰kV¶æ‚•›¸ÜàfnC°rç©Q!Õ©ƒ¦lŒ:5`c ·E…Ô5 Aê®Q8 \uI u×(wq—65j’ÂSà ÙÔhI”§F‡TÝB,•\1–ª®¡°1·Îƒ/þ 6¬» õÍ-S6Z›°ÑejÀFoS6» ,*Ã\÷—È5üS©ºFÅ.2¹†o«Û¨ÈSÃ3¨L ì±ô©¤”©œ(‡=‡†Î=7Ï·¹o&ÇË̾®I‘b¥Ï1k3+v_Ò|›Æôɰ§´’ÊÆ•”‚‡Fœ™ªK\ÂÒâ{IpR¥Íw5iA5ì¢b/“g‹b ÀÕ?ÑÌÏü7¼«êþ xê› ­xÚã0©GºâûÕÝ‘“êqö}Bn¶Ô õ(³Â*u_aÎmNN6Ë‹t°0Žò«´¼þý¸H¹Ì³Œ@ìn?|x³yòä¸õ ?¢0åÎaÚ$w ÓUs{¢–…éÒó(qšò°0-’ÇÓ\3I˜¦– i£Qd²gt”æ̦{ɬÒf™Ð¸ŽŒ˜ß¥O÷»›tr’–S!EYžj§Ø/a‡œ4“ÿ¼†Óèó k,/¯÷—gÛ›t‘–—/NÓr¾ýt“¾,þï?[üãíûífySÛÝÍGoæú›åÕöãþöúr;ßéáÝoÛwWoŸí?¥  ïmÈz{ m”ãøt·Ûcµ‹C›r¾2;ÍrvûçÍ|þõj÷÷fy¶¿~·½ž‹Ó›åçå—åùÏ÷ç_‚ú—½q fåÙr ©‡¢Œ¦ƒ2¸§3dgiùi¾Où]½¿½Þæö£åh'¼•~Ù ¤‚o›·¬{[vü¼Á6˜(ŽAZ{ƌҕ²÷ªèÚ’½ré¢ÙF˜”F ûͨ5NSn=LŠ#Gi `(¥a  ·00(N#CK˜F èÇA-`Œ0­(Ž¦ ŠcÓŒR¦Å‘Ã4Zk˜F à¥ç^(N3ªŒFi´ÌŽQÚ+ØÓÖr‘0ö‚Ʀ9—¦µdoNAºÔ¬¦¥emašGöA>Js®%LSÉÕ¢4fè\ý¡ô–ý–¤ÛÈ~OˆÒœ­‡i+¹q˜®57 Ó¨>­I”Fõé§9÷¦Q}º…iTŸ>Â4ªÏ(-¨>£ÆiƬ¦»fâ0Ý0ˆêƒ³ümè7R%sáиzgB½3»âšZûÚìŠ'¿üq}Ü$ûy=žd1:†&Y³9¶Þ‰„Qp\<×h”q•}T€¿?n+7ÓGÄ-:fƒ,h‡(sêÑxþÒ^¼-†i  ë£‚­–Rͺv[\§áI]ûlõhSŽ®,¸3ÖÕ!d•Æ…i½õ¯Ñ<$ÓÚo ë4<ñŸh‚´bx²èW2aèûzx::ÇIÿíëñQ‰ùîãÐäþqhôýÇ¡qð8´•Ÿ`ùþߦ f3³(Mßš¶Öèy¯±¨ß˜´r/íMtõú»F«®5Gùn72 endstream endobj 3678 0 obj << /Length 3397 /Filter /FlateDecode >> stream xÚÅZKsÛ8¾ûWè6T•IáÅWnŠíÄÊʉWRfw+3Z¢-V(Qá#ç×o7|ŠÎ¸ö²>ˆ Ð ô×Ý_7Í&O6yÁ×·›‹Ù;N'ô<5Ùàh¤ÖCñ!Kò©ô-óà]t,¨•jœÀi]Ïu\¾zÙrŸíb³Ò)ʧܵ¢”å ‡õVêÚË`¥´^ÎF‹HÉ/ûš~Œ¶e–·'zÖg ×CTæ ¡۪€­°¾à£<šÖ«‚’¥Ç¬ûý5M.÷q‘—ú=Tè,@ݺî¹n…ò´në±›m–š÷ù˜å‡¨¾YW'=ÅgŽ/ú>¤{ºC’'q•Çý}.Ÿ³ã%5?Té3µêjˆsáú÷ü!ÐÅË@²t¼WÆ×@£çÄ@pàÄð™´®²cQæÕ¶LŽO4ïÐËŸíCr„ÿ4ÝÒ*à »Š”RYnÄ«´LóìXÇÔXk»bÌ¥ë®W+v>•Ìºº£3ÚL]×"ˆ À È€¥†Ò]ši¯HzËË‘±œyÊá {ó8£)þ`.ãðÃßpÿ!<).=ù#[”C5Éդܮš`a—¹=õ(WÄ”ÒÚÔóØç2ÊwÐæŒ kq8Á±Ð@öH×<Îòàõ¦û´@‰ÁÒoRô²æºêÕ'RdéwÔIœ£zÆTês'A}Æ÷Ó¢[íib³Ê¸ÉJƒî\I`sžô:!ê($ñ£–¸àA«'y7<áÈP ¥Fõ^ûiý#ÊŸOIA7úø%ø¸ßkUiÜKuˆÌؾ ¬»f`Ã>ò›Ž`²ÞÈÍÈV¥#‚f§›‘5ì€×‹‘œµªÖc±gó<5ÚÄœ6Ö³=@úÚN³¾FÈLžð'&qmö­T^&h•lØûÙ8“Š4‡÷ž”ÚmsÀÆúH_ñ..À·ƒ’ájuÈzôí»©r­$Mí¸¨mÓýI¿ƒQ(¯kûÌfÓwM,»ö”~×|-&YÁ°W9lL—.hSÈ6FQT4½´W=a—V36>VP^Ãxe̹ƒšyqŠ·åe>HwC |ë6zHÒ¤$6¢Iä~ørŽôâ{î’ k—äÉ€‚n5ØÈŸÇùVÃ燞£„æ!êb‹òºÀ@ÔMÙ4N½pˆoSt $»MQ‡T˜aü¨9Αü·¦t–EEBN®úNjÄkÖÉFPî±ëÒ͇ןª42AZõñøo«Ì\)ëGRî±å÷±# ìK{OhÆñd7^Ä”ÀjZž‡S5ä`™r`Üa]0ÔAÜ Ñ¥-‹†úè2üƒžÚÛÛ§mO6Üÿoµ?^‡¼v{«*ù©¡K¥èANE¹8Ü€A‚2ÊýÁ 5£kü­‚|ì!Jc™>ehå‚ÿGaæëÃeX_O«ÃÑôbª¤›®†vÕUeó.çNÆ(úªûbê—šÍï?ÍŸ)ãEÏ?€ñµ–›Š´ùŠ‚ n¿¢àab«ùräÃÇ|ioV6.c3©^§ ù2yRÒZo÷Uú3Ö®»ö9ú85×Éwø:Jé4¤K°&®p³Íªé ï4©‚+è¥Ì6d£ú– §f'{GK©§¡VÐ>ÔWjÊ’zäåŠð˜‚Þ.6£å¨!RXÆe”ôL“Ó@ñž¦úÇ+%˜þÙñŽ NŠÕs=K3Ïwªn)b]ÛÎó]¢>º¡R;4t µg¢;* +%_WR´`ÇSi‘&Ëu–aÖ jˆí+ŠƒÂÜþù!O Ž1G¦Òž=H’Ì7®[×’ÙðWuUpÔ5B¢'|uö}ǹ6n ž<Œ 7­Iš,mao¯ã­ó‹,7„”ò¬z¯Æ‹e›Ÿús"„è4Â~ÇŸ wD‘y4Ìçî/’yX®~ô}G¡žO‘¥´¾¡‘U¥=ÚÛ¬ý"è!zÁíPWDO+„èAß {pÓ ÅAxùp+z ‚D߀h¤&Ñ>ìèS­>a‘¡>C¿òpå6ä¡ø ä¡Àμ΀PáJóS]ñAA0úÐT·è¥úÄsžÕuØgÏ—C€ï5gµ8+ÅId¸Ü¹Ic/Ú¬ùAX:àbýOØ…1¯ƒ¼«KzFšÑºM³¶)}mü~0ø_RËÉøìøX¾X€“ãm=?Nâ¿h^ëJÑòZr’ÖÈq¨5räj#G¹ŒW2E阖w’ãɦ½˜×ém¦4s±B=(aÏü Hg=n<¨eéëR¼GÕáø¡Î¤2ªÞœ›ÍÅZÊMì endstream endobj 3708 0 obj << /Length1 1369 /Length2 6022 /Length3 0 /Length 6953 /Filter /FlateDecode >> 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 3710 0 obj << /Length1 1536 /Length2 7670 /Length3 0 /Length 8699 /Filter /FlateDecode >> stream xÚ´TTk6 Òˆ„‚Ô‚€ÄÐݤ 0  030 9tIH‡t‹H— ÒÝHH J#JHúzÞsÞóþÿZß·öZ{ïûºû~®ûacÖÕç‘·AXCTp?/P ¨¥`,y@b66(Ê òLÌfAºBp‰ÿ2PDB@( ¦Baì´p€†›€_À/"Á/*€@ñÿ"%;Ô Å Ð@À!®ÄlŠg/$ÔÎ…IóŸ_˜À/..ÊýÛ ƒ ¡` BÙC`˜Œ`@†BP^ÿ Á!eB9Kðñyxxð‚`®¼¤ '7ÀŠ²<†¸BîÀ¯†Ú äOg¼Äl{¨ë\a‹ò!! àCà®7¸  À$è«ktœ!ð?Æš ¸ÍÀÏËÿw¸¿¼‚Â;ƒÀ`Ì÷‚Âí¶P'@GE“å‰â€à6¿ AN®Œ?ÈuYc ~W¨Èë@˜ÿjÏŒ„:£\y]¡N¿Zäû3ee¸"ƒÀQ®Ä¿êS‚"!`Ìؽøþœ¬#áGÿ%ØBá6¶¿š°qsæ{‡º¸AÔ•þ2Á@Äÿ`v@ŠŠ .ˆ'ØžïWx/gÈo%ÿ/Ó/Úá °Å4ñ…ÚB0b´+È@!Ý ¾èÿVü["æçØ@Á(€5Ä 'þ':†Øþ‘1‡„zÌ€îñ€¿ž¿ÿ,0ô²AÀ¼þ1ÿ}¾|&ºz:Ož<üÓñß:„'Í#$àbø*" øþ;Œ.úWÀ|ÕᶀøŸj1cúOÅî€ã¯åàü;–6ÃZ€ã’›…`Ì‹ÿÿ™ê¿]þÿþ+Êÿäÿ[Š›“Óo5ÇoýÿG ‚A¼þ2ÀÖ …Y-f àÿkjù³´ '›ÿÕ©£@˜5‡Û9ý=D¨« Ôb£ Eíÿpåþä׎9Aá]„+ô×¥àáÿG‡Y,°#æâpÅò· ‚Ù›§T†ƒ6¿L@XB"A^Ę#ÆHÂ4?fm ž¿) àã…#P¦9_€-Iüë<Å„|¿ ß’¸8€ü·Ä¡äoQXÀg‹pCþ `ŒÄÔþÃ1>ÌM÷O~Œó‰˜tÈÿE|¨`Ò¡ì‘ÿJ Ä ˆ0€çoñ_S»!‘˜kà7K1#úüûÎ@Q¯ñÂçÒ2þñØZ#ñÌèž…ÛòµÝ Dô<rë>W.>†Ž8 Ø­l¹.nbdºù”?<ºT=k»Kæ†Â¦ÖôÖ+Eݼ,ç‰~òÜ<ðÕG¶<ë¬I|!Åç­Ç'9~2iÄ?$ö݉|‰6]ˆ9›ôþ\f àÚF{ŸÖ”†ç˜bhŒ­°‘¢qw]\Q—÷qò•š×~ãê·µÞÑj›÷ É;0ÞG¾ãôÒ£ÓÅÝ;"¾Ì!/ó#ó…gi&"‡¢@@Ö7Z]ß)z`›#È«­)0Ú¢èá^wKÿôLž©©Ãà9Üs&3­‘Ô7SÍÝ` ¥6Ãbt Ît%¿V­~ñ$º&¸3þˆhi›êx/7©¦%ÓÜöý²ðXçû'[³¥4¡ ÙDÁn¤9˜ªèv.û"‰âo£É ½+èæ£Â$>1äÖïÏÈ|óªºRïxù@‹!Ãöö“ôÁgÅ#åÞþBÒ±ÖK Ûè·_™骉hKX1( HÌ•ØWqë"óNsë:©ñê®ICwèúÀî îHÌʾ”%ˆ8³‰yæ)ÆŒ^H—^ŽéIG¯fˆ9~cöJ‰Á¼”e¢<1 Jû~"4Šk×BÕî­gVk {Y¨÷öXC=ŸÃn€Û3YÏŸ¬o>/Ÿh±*ï+ìjæúÞÅêQÁõ"±2áFufŠëG÷JÖµ\QBI^ÔÎ9ï°y¥ÛßõŽ-U¦—­ù ²ËÇÍd•:³/U§ÝùfIkZ˜ž5WÖ°?õÿ6²üô'‹’¨ÖY?ìk€ ™ÜÆrAîG÷÷T鞨“ _~¶ ûůã¾2•ß9{(A¬ªÌ‡… )+Q,iä‘„…«œç€éOÄöRo+˜ÏGÙt‰úV&PqrÕ輦¬…Üv÷³øY¶× …GçÑœúklýíÌIõV¢ÌGï éfÌëD ¦c?M¯ÂUD7˜8ÀÅD gÏ.¼hbwÛingÐb'ûýØør[‡1íC—ê¦ ýÝítT·ÛÚÒòN~+Kc†ÏMtœ,§äJó¸ÞâŽó4$‡=;ø¶²Vɨ½°õ¾&EPŸ¶kÿ0TÚ'Kÿ°œÂFk‡=|tÓŒa4y-~j>ñ°Yù=,Þ¾ÃP;™]¯Þ¸·„'î«Ì£Gs•Ñ÷žã¯šÎ™ˆ!JâXÓ ݱtšëHawšYW=¨hù¶nže]·ï1˜?Á:¶zÖi¨XªŠSî}úìi£.2$µŒ•š[2µ}›7Q™‰´˜…ýÍJT„‹è4"… [2NI׿$òé«Ýíõ‡cçÊ×=lëPNi>/½úä¡ Ò9ìW-ç¸ :ÔÚ¢¥A\dç{,bI"ñ _ë"j /’jfä¾02 ¯ÐÔ¤Õ:«¬M»Yæû 9ôSž&]ÙØ,öŒÍš¥ ÅXA?Ú s÷€wBpI(‹¸g%6Hk5¹Åœ¬Ì³Ð*ÁiPqÉö2@¤Ç–QwBA¡ µœY rÞñÁàÍþÔœ@?ÊdÌ~e…s¦7JÄx3?'Ê»?»+»«Nåj’¦ç"¥±€$èû2òq»ÖwÌn€/Í<©eÓqŽmê‘ØÕÅ-õ›%Ýêö[eî9 ¹;¬ “ Šµ3qV;ùåpl6 Í&‘ÞYæ­½Ù/îwƒChË>Ÿœ˜Œˆì)ú¤eÉš…^>À%4iɈ?|k몞xs =d¾ÚÖ¢Û÷S!&NRˆ!ÔéÁZSS2œÏTb!3gb~;ó}±Ïë.ce¨¸÷4{å¤%›h3éw0qÒö”uMµÝ½˜ø¾¹™a¤ùk3ÏÙÞ7 ‹;|R)%÷¥\÷˜T'É{u‡‚ž!Øú£.b¬*MR4*å’¸«ä«Ru-UÃ&Giv½ì-v7Š¿÷ºˆ›6Pã(^l›¯²Ð5Çʆ|¦²†U0ªãªÚ™aÇhGÚr>ë›Ô‰ óhºÀ:ß©«‡uÓ Zx@5…h,‰’“×¾cI„Ý|~¦–¢ßáÁÓ]NwI7v!(Ð º$3¢„jSù{oû}çpIOU„ÈZõc^‡à"8¼1k=7¢(Ý%òœQµä§Ãj YF¦ˆù8K-}¹ôJÑ ÿ;µHžBµ|”Ý¤é „™ s•¸ø(Û 9nÛu²Sž¦² Ë Nÿõœø¤Œõ 9›å;:›U†”0Å[Rto,?Q~OGNq)&ˆ†Q°|—2¾(ïì³o°ue/¹Ùgo'”˜˜pÎú½¡ÿñè‘e†Ò×m|O_Cï OKÆTŒ}¢ü«ðç<®¹Ct8ÒTŒ7vÄùËFÒaè†ÊF#z{m>ÛË67#rq’”6 sÛÄáöL÷±·®FNÞ"ùLê‹T ‚&oÏßáÎñˆe£Ð¦G¤¬ór“Uo/]‡e«cÓ̱§´ëÞ…¾±sÇ[;9Jb»›Ýk#æq㎡[×vžÃ¬(lÊ£9±àä‰Í¾ 0îrh§õ#Š[ 7?’û3j¨Ø“ÉÅeµà'2´ú¤ ÷g¨»Ó9AÚºªû:%ÏÇ=¨ÊeJev7¹sj &GöPM• ¸ê¥ï|K|tlßÿÀMhKÿ4ãšU~*-“wÈÎM}ϱ¿Îð5çÝn“úËK7K!zspnTØí“É#œãˆ–èx]—ÚPj#Li6Ås®yØ@SŽVlà¬X4ú“;÷ìäíw…ßøÅjš%8Û4^ŠAe ìPÌ-¢ý'x=o-Í'¯ Æ îFÎg{t}#åø0æsX=NàëíÔm}}+X1è}„…¨÷Ûª;õ„+å 6qŠ]^Ól®Âú“€±ë©9«—ƒwÒÔ½÷¯*^ARÎp'WÚBcïFíÞ!(|”,Ì«ïÎí3+r&ýƒêÈÊ2ËÚ`^ºcôãÂ¥Š„0f?eROOä.ìä\º2µñØ×Åâç»Ù32P#^˜õl— 7ÇgÎÃ|—•ó_¡ŸWl ›X4ÃØÍeJÕã…Vª^äÖØä¿ùv[ÇÎ!Í4ø¶:ÏÂbú½¥LÎþË—Š”²44–/OÏÎÞ Êp\,U§Ã¶‹sãžÕøyf(}HíX׆ڽ³3,¢fs *~ØJ­ŒLÐ`©3¿7 ZâШ×\¢a+ÍZ ãdÜÌërQîÖ’×Y­º9Y?Æy0·ÉCJc8²OæQì3ÈÒn xYõN•¦¼x*di„‡x°¨§dDoc®÷@&k¦ÔåJNpeQø™¢6ç!Þã¿ú >úˆ«„к¿¿k ¥å8k‘p9JdhPùÙ5u¾€Ÿ¹7©ÄŽ)¿|ü³E½çµ×êÕÔ—/ÑC,bºÙ4Äù¬0Ýlûn€… õkÁgoÿ9òsf¿V«‰ 9ä]ËÇ©n8’¡*2÷Ýf¦õšPŽ¢JaÕØÏ[·>[bçjìeh•W}f+msÖw‘»Í¬×œ¾4ÑqÕJïe.ç»ûjÀQîþ5a%pKÊíþƒp¢:˜ž€_p¬¶Ç' ÿ¹ÚBt‹X53¯–õîñ^^”îv|QOÜì±Á½Uh¡5NŸtVÇ)î<»qå°þlùåµ_•>˜±ýao÷Z•“WháÏ´,¥@~…Øuùˆ)NwF¨¸fÞ¨²všé$t4ï`}Oæ²]]â™HÂy(:èd÷Š×kùà@(l²Öí›Ç%–¢‹Dˆœ¨ÔŽó²úÅ~fóq¢öŠ)N(Je€êf ×6FºÔŸnAU(¸#)V†RÓõ§zU¦ ¼·óŸ…x2¬¦ÂŒ“2o5Âz=ëœWRS>ê)Tb3pÄø)¾¶úÁCék0·Ý¢H²A™óå¢Üp x½eͪ"ˆ…•·9ò>ÖltÐ}<(Áyr q(µ»lu–2tÎûªþ©4úTù Í6©ò}«ƒ ésü ÃP½PŠrF6¥ZÄãŽàº—Kžº×3ÕÇ’.ßðí.àÂö²Ç¨°›‹ê¶šI¤” (báâG…¯ø6¥ñ¬Z Õ’è•òf´}#º•´X°‡‚Ô£¾Õ3à`ßP§»ÃÀA9úy¦ómÄȧx ¹OÀÓV§´3ãi}Æw{ÍôkÛä.7Ï·è´~L—}Ê]û¹Çø…¹Í°ÈüzýÚe^? K9um–ŒÐ¼sïä¾^F ò Üd‰úÙu™—^¼ÞÊÌ+¤;‹…\Ô‡É{<ŠÓGzÏ¢ ‚Mx øå=±ão:jË= Ÿ}´zz¾½ð J·ùsµ¶JLÒ4)o îÒÎÇz‹,.fÖü'æ…Ä°æårU{#KôE¤ºµ Ñå6õˆ"»P«4‰¼‡ÐZãÓJϘk5Oû¤_g!²Z«ùÁÎr,\S?Â1u˜èƒï”B·:—>Þ ˜5þPÓ“TÚáQ-ÉÓ]{؈*îñµ{«ê¬$š°IŠÃk4~³f×S}.'¥q•5ô²¸l“†2Ú¶!– /Hª¡™³õ‡nx…ð¸ÆaAñ ¡y“—î<úÔk%võ*}ÁÌê;vÔÞ™9²~÷!d7¶ Õo$ùìVß+àó¿í£•~®"qî ?݉¥ÐÂ"¾8åbiË‘ùP>è>ü*ð{·Ѩœ#Õõ†`U”Pç€*µ#M…1í:OZ¿Ù¸Ø±´¾Âb*Ú8‘)ÎA\Ö¸G@»,ã Qïìf1>©{b¾J¦E”FÎy§Â¶Ä8L07}Á¨kRI`œÝNaþ€tö°ÈÔk!ƒÚ}ßÀ¨tkòu^þ§*æËkèSÉѯóšß? …Ôrò[zĸ§=yö$¥#|0S6÷ñ\Œ•¶“§æD¡v{Á`HZ¨&$õµt‘¢S=–±mì݃û~9Zɬµ=—sz–fÅ™ ˜Lß oÐn½¹$nl)Ì=¶À)èìh‘íŠ/X!B›XJ¯0ˆ®Í`ÿµJÍÙ…½ºi¡÷Ò—Ì©Éd'ë`ž0ßÛ×c‰×wxóî1ñΖχú¥2­áÕÆ@¾µÈ“nN¬ðo¦S Ÿp_X·åÝkµk!O¸3t¶~ q'ÄÏÈr ¶i¿FNZ}UC¸?O¼ê^ ×ò@]®éÜ?Ë~jyfàòjþ-ÌýÚõ‡è…eˆÒe÷Å”2WÅëÅÕï çÃo~gH,¿ÐmíD½Ô8ÐïQשR±â˜«¢÷®Kä9. ÆáÀ–]oÕüþ9«B‘@xÎhX7¿õl•Nö¡ä@哬Búq×yG®Ûò*y²ãª"K¡º‹(‰µ~©Ç’ùðF±þìÒ —þaOíMß#{_³ØZÙÜp$§eôI_YËÛ¦qiù{×qŽQõÏx¾¹—MÛçíœÃòI-ÙêBý¤ènO÷Ížøaúòtòïb³ìï^Þ< 9ç¡ËѪ ²‡†?ÄØ@ð³½Ùy-¿•H¸ k@ws‘I"ßæt.~åR”kÎB—ªuÒÌEsh ’tåN-V{÷MÈç~Ù@ù‘ˆ·÷>5søІ^#ÁTQCdWŸ|¢}6%MÕ Ó.T~DZ“Þt¦‰Œ:}4x|œž¢„p³(¥È¿os¿ŽyYå0€²¬§·&Õ¥pXHæÈ;êŽrþ$ç 6“¢gÇWZ'[¡ÖpÀÇo±o¹FóGÇÓ`ĉ¾QÎЀÇ"oŸr¯V×®˜gzçnµ°¾]“óÂÖ—gëШ'òÛ¯Ìå\’ådª!Vÿ0½òýCyÕÚÅÒl’ý›nÙ´»ÆëóÎÇíY¼ª#"Gâ‡Ö¢o‚éJC瞶–Ÿ%?a鶕>!7òs i'íÈ.×»»¯1Ax îÛ¼™ùùB¬Ìjë X¼Ëáè†ñã5Ñö{‹F•õ»ã¥)âîd5¹ÎOœ²+-ÝG/MCL­FšUßsKa÷£ùqkÅB–¥Ú® ºý>êý¸Ú¼å-1Û¶Ê2v¿ÂàÐûÙ¥.°uó£`~>TOƇ̭”½^{‰B·ì’Àì¦ÃÑ ö§,š#Uþ“ï<[“˜˜˜5׬¼[m›Þdk¹ï-ÌpHšŽÓEQ”ߟI}AÜ—·"c •ÊxÝr `R¼ù E.[ fÖB ÎmZ’ͳ<•Œ}r^¯'Tw Âú¹é!³Ó>MY@¦Þß´º^ýŒ¯bTÐaÀú³øæÔ æ²‚—[zÜ·.=fÅn¼™~Å°?ìŽçNÉ2aß%·óãæx'ß>¼öô-Gˆ£nC[¾ÊÂsO„^Ä®«àÚíª †v•{¹ˆ€üwÔBX&uÙæ«`U!ƒp¢Bý´mÛ ôºtUÚÀ¨ö“˹`ª6V2Ë&±3MÜÀª­ õ\è{øk±hÊ´ÚZïæøF­Êê‘’ZÄÎ]¿w$OÆq××ëi—$(¼¥ÐHxQ!ˆ!G69V*ørÍÁc¦ˆÀ¹D4!öU…žHJÄRnÿì&Îýó's(œ8n¼¼~}[ÃD{U©¶²v,Í„íMâ%‰úÄ&î$—Jvq$æÜá;øcV[NÞ—I¾dt¥!)Y»p…¬ õÛ&U¦'e¤ß©Fs.sP¨h»h?7ÎC½„ìñ«wL¦Œâ|놄4\`ZoÞTaº"lgVä($µ]3Ÿlé[V;ƒ÷Í}†á ,ßf ,®%‘J–jl=mÄê;š èæ…½T¾CÑã½xÕ¥°= Ü_×…"6v·´+âøÒ|2dZ\'„?´$ol=†ÔX-¾2Y¬çÅÕ%Ø·&°ÏaÇÎ$éû®¯”qÃWÎàU§a˜/wœx­‹GomªUGšúö006tpì¼D2C ¬ê)‘;ØaÉ®qü#äCM¬J-l¹ÅÖDº@{Th+àè„oýµãzþQ´Éià®`˜‹‚1vEbÎ<àK{۟쀼ƒ¶£ç•-?"Ç œC®ØÑûÁÎc/Ú?t|.t}x…öô -§ÜèK’ !»YUÅ^O8¼ Ÿùaƒõl¯:FzÁæÀ WeEpŽ~”o,Iµ•ù»™ÎVózâº*\» ïÁè䇤L&.zdGÌYâ?Å™{¦ÝîìÈñ¾‰ü‘ˆñ2nK€8Q×c®gÓw\´ÂïÝ/$mH7: –¤…É_Ëp1Œg”«½  à¼ȬÊñZÆʤÛá±¾¦&rã©’R^Ó-%«Ðʪ˜-ÉmD¾ ¬’ÒÓçåžœZ¾£P“»ü2ªœ,Eë ¸;s!¥ºüx;ýÒ á¸mµ‘oû±Tëì®×€í‰ùµ¸ò]FÄåχãù©kÛýaäcÝb îø3o%#rÐß"* Pâé^nêM¦£h`ž§æ.â÷_Œ°>ßs¤Ü†$KÖ.¹Õ¦I9 r˜*¯!è˜e¹ÛYt£¿FJöÅ¡E‘æÎéýaÿøDôT endstream endobj 3712 0 obj << /Length1 1559 /Length2 8910 /Length3 0 /Length 9936 /Filter /FlateDecode >> stream xÚwT›Y×.Zܵh°Š$¸»)ÅÝRœw-n…-w(N±â.ÅÝ)Z 8ןÎÌ7óÏwïZ÷®¬•¼Ïö½Ï³ÏzÃD§ªÁ. ¿ÊÁaÎìœ !€ô+)]AÄÍqa21iZ9ÛBÿc2iC¬à0¡ÿe í;?ÊdÀÎv¯à0€¢‹-€“ÀÉ'ÄÉ/¸@ ÁÿÂ…2`W+à@ƒ:a2IÃí=­,,ÓüçÀlÆàägûà iu´2ïÀΖP»ÇŒf`[€ÜÌ êìñ¯Ì"–ÎÎöB@ ››ØΉîh!ÆÂp³r¶¨C Ž®PàwðôÏÎ80™š–VNÊ5àæÎn`G(àQ`ke…9=z¸À PGÀcr€†‚2àµ=ö§±òŸl€¿fàäàü;Ü_Þ¿YÁþp›™ÁíìÁ0+˜ÀÜÊ x-§ÌáìîÌà ¿ Á¶NðG°+ØÊüæÑàÊÁ9I5ø±Á¿Ús2s´²wvâp²²ýÝ"ðw˜Ç)Ë Òp;;(ÌÙ ów}2VŽP³Ç±{ÿþ`z9]¡gG¨×ÿVüarr Vf΀7P +æ?ÑÅPó?ñãá;Z¹ @Üã€~þ~2z¤³õøÇüóÊ*Ë(«½fý³ã¿uRRpw€;¯€‹àääð?>øü;Œ*Øê¯2@ÿø*ÀÌáÁ?«}Ó*vý‹Ì- àß±Tଅ˜ÿ!¹!ˆdöøÅùÿMõ?\þo ÿåÿEòÿ.HÎÅÖö5óúÿC ¶³²õøËà‘´.Î ð þ¸°ÿ6Õþ¹´Rp[ÈëœÁk ³°ý{ˆVNrVîPˆª•³™åŸ\ùS®õ{Çl­`PU¸“ÕïKÀÎ ý—îq±Ìl/§GBþ¡‚>îÍ¿SÊÂÌàß ÆÅË;:‚=0øñ¼87uÿƒÂ  îüèxlÎ`wÄü}ž|¼ äoÑŸˆ”ú €2#~nPáôh©ü7€ªÿ NPíĪÿƒ£hüƒ³kýƒóéþù@ð?èQ÷æoÄÉõ˜ÐýÁÇŒÀ ÇÌÅÑññvøƒ¼“ûþã*‚BÝ¡f˜sÓp3á ë/AM—’”nì?†E'˜~è$±°{Í96»\ã¢}`)O}»ìx.ùá[þâº,ó™Ä<í×n}5ZhC¼Zã÷­É{õ±˜³£¤=#¹»’UÝÔTìš›ÞwÞÚ6Èõˆ­ŠL™.¸ªÙD—n]òîUÝE ƒ!Ó?Ô6Ëù”°n‹ÆÙ£µ¢  &™²Þ¤M‘Ó?qf§FAxäŽ7yv>A˜1ò@«øžÓg/š;ÏK…ëÝÕ”çR‰&—SÛSƧúäÔÈg„ƒcϼ¤¶?*’ÍxæÇ(†Dæ›SO׉5ãx*éZçDŠFVÈšHᭅĘ©­1I}ûi«‘ÑBN˜YÅ_0~Çi’ƒé¤Ö²uGêYpÀ+V‘'NúiA`óX8F@nÀ§‘X-Í›])ŒÍgu MLUs™wú6bÌ×B©ÅÇj`È;öÖ(PNJ,uº íS^Õ<'ÑC›±p5Ýó@m5º ‘êF¾|k<ͬgóÓZÚ ×#ˆ~2¾å¦º–½úýnZ¥‹8[»:„s|üŒ–ÚLÎ}Ö„Ë×k|Ôå­”¾Õ–d÷W"Ѽ™m|^¯ æ!grÀégäfŸÚ‚­¨iÂé&T’…㥡O¬:÷ øX„ʼNõ–t¹ÈW¹O.ôHÑÚ¤¦°±ñ{#Jêažpž¼Vø%ÖÔÕÍ<“Çc¼/N‹š]Žó\iŽ¶³†j:Ê3£–$ŒÅýmsÛt‰6—né»!×àð9!±V8ÜS‘’—`¥qŽOz"KÚy{·«z3Ý«K°ù¢'¹K ç!w=1©ßæ# xi<Ëþ•`¸a¨­Aúå×ý*}\—žMCM54àÒoû ¹B¥¤ð$ÐË Mñè}ìòñÇZªñ¤¼Í……ÚÞH/幟‚†Œ°dÉx'÷û]AlË°ñ¥|d‚Bb²7ýŠZļKžnß-õPY´W”¦ÕÒó‚2Ìɹ!8I48®&=Qø¨ao¬?Õÿå]S²Á‹—a™ÆÕúb.H¶|€„W’‡J§V<çÊ»{yoxEU:ïIï•{-Ås€BÉh, 2¦+e¨V+è¹"ò{¸C*1ÑDxËv׃S,ÔbåÁ›xö6 †>YÍ‘BX 4]Ç–Ö•¾ÀÑ´9W 1ÿÁfIùjL4h^´¸ÌW»‘S·&§ß³W ÙOãá­›°åÇkr·2·—&l¥Æ¾ņ´«4 •ÜýݶÏd}Ê„Mwñõç‹Y¨?UáÕÅ¿Ô'8lÄ]âú·*`v s»aZ^DeD³z5¬ÙLhhÒ›h'ŸJJoõݪ—äê´Y[°¯»¯V·DÆ{£„FCžÊ8}7Aà¤æ¨¼)¬ç'“Â㲄Ê.”n?w9Ó¤ÝÊ9ïñìžäD¤_åPaHb…¹À¿¾Ýü÷Š!æ}­r '@ìÏñ_œÇ²GU,šå¦RË—æLuÏæ #¡ÆÄ­Wf‹³øç–RB¾ü¯pÝm^ÉÒpú*ž%mÚiÇVöAeÐ.š'4Eú+@<¸¥Á¦4“ª=Ÿ¶)”a¬ã(6e6r9zá造’Ùoö©%Õ¡¨ròÀ •)'G\NÙ—¢bDzcrÉM ê¾:ØùçÍn•§(ù²=žæÊ,Üý$îd1\?¸Y0í+dõˆæ™êUtSÒ¾H\fÕK訩m÷â´µè><0:â@ø‘µòí²Ý•ùX[¹póª(çÀ“]ù¿2?¬¬Tg³ÁêµßäßúK Å}gá8Ïñ|7 ¦gG<(°–¡+ýd.TY®þ¸¿!z97åÍ©ÅsóT,.@Àw¤ Oq(·xÉÉj:û3Nm¥jÛ<`ŠOóØQéÞÄ=o$ª}{ÛæÅ/+KŽ|¦uöiö'“{§:z‡!3Q[S‹'hÑ·µ„ÆïÏç„K>Kì !#Q'¬.NÙI„W¶PSõÓË”½OdúJ|ZÓšßc“G˜ÂîMBò)×Ùý…Ǧ3¡ˆ¤ˆ5{àÚQæ-“ ³—5ÊåÝãe\ï-ßs—æ„#+$vQÎ(—Ÿ}½Ò8!^ºœ¾g#&Š ™F$é­+%‹rìô kö5®ÏÑè~Z}Bxj×N€ÐfMº¸ÐŽ#˜«/楺úøŒ#®U.Ú· AÕȸ.‚_®vîÊý]( ©”hgÉ1é¥F$.? ]œF:Í8owBzÊUbƒ†«|)³3JôšG¸%”@÷3NLMD7ñZ•Yç’¥ôaF>Ç0φœ™·l"{+òÝå:o!ökI õpnÿ êì*”Å^ð²nS*°ž–£”St&;'2¯ÓbŒÓý=Ö÷ë:Â3÷@Ez—¦á£áÓø©ƒÈãÝ2 ¸Xî‚Ÿé)ݾu“Yb†«SE•õGf×-û*YÆä„«ï÷ïwòð´ ­:…ó¿Ê žŽ{g3­<º¿ÝsÙš”±qDJÛCÈ4çúÚaN“5žÔàj Ç7d=k´o[?%³3³p›+HžÈÌjÉn6ù(k•¾rÎaÁèú\^Yô”‚”A=ø–åº}eVlú‰:½‡*’¶yfoêzèk3¬Xtò”¸%¦]ÿMã=¸Üû÷îD²)3Ëg6¶Xý4}ŸDVpùÜ<, Í;Ž\¾ä¥;ž0™LKÃ"° §»ûŠníSWŠ\/_¥ULAžŽÏsá-àu[P`S~þ`­>§ÏæžZÛ5ê8,' %Â,xjú½Ý­W§u Ù©“†M÷&:' «žSRµuúW5›Óo<-~SŽ’†ö=Qä|æ±%»6Nx½q_C9yÓ¨ÐÐ 2ÌøºLa¬ZØÐwVLª´s?)Ÿ ùU%ÁÕ_ø)sú6‹èWTeh˜í×ÁA r¿£~𓘘ŒIC_[š:ˆ3!Üg襾“[~.í§—ð1´ÅÞo ¶=&xefÌ^™ìgѸå™K{ÿuRˆzºÈ+Ÿ€0&lnQÌOA‹ i»ŒhÍRµX,K*nñÒÎ&$Xkq[³­×§nÀŠÎO‡õV­p‡êV7.ð丣ÿUt¥Üs´[àç S>ö¦H–`c¹Žó̲ע)ªîÕä,Œ·?3ÜÄŒ–·½šÊ1.M/ ¼s*Á‡±¸Š[£EÒ"vW1 €ŒB™s Ó#4ÿÙ¶ø“¨‘ÁiuÁnü„8«7PÒ›Ñd™ëU)ž©”àîÍN">èDæt:|ÕhŠ6È0rˆL·|öç.½@ßRÙÏ_*×Ì”&ê}ÑÜ醼( ÇȲÙêzjÍÈÐ)ß™£TÂ[æåo²:ý„\ÆNéÔø’ù¿Jø…³È~ÿu‚Ë–„PóÃ<È~L²µlÆ´änBKBt‡Aë™FËdTô­d°‚*I·&6pù}Ç»* [µ!y»¿¶kÈéç0T–ÖˆGiåK»]·¸»Z—g¤ÊOê‚)YSÿd,S`±ÝˆÃF£·Nða";¢ÅÇ-¹ãæÓ›9"ÍMtóÇ©‰âÝ 0‘ô6®õu«:îϹéóß ~Äw•\#â(¹Dn$ã•ý!jìUeAÏ7¢m~û @Ó•š}ø^‚ÛOY„¡Þ,ñ%Fš2H-Û…Ç!"÷íôP&³´ž”ðÆ÷Xƒ-X‘T¥Ï57Fûá¬Êîá %®¨î¨¿. iE^/ÃC¯È3Bt¾r e„‚Nö—ùn“èRiBÉMƯfû ’goL÷)VoûñS½b&½Œ’01Nº–r³ésÒ%Ïí&>CQ|j­(73SRWiáî”ÂÍ]ÙWù q,I]AŸS¨\“½²'ãÊUÒ‚ kf²nŠNûý<1gexbcšÅú]6hmÓ+NOPïväcˆìJœ÷¢H0 õG+‰¶•*/ãPñL“xÆ«tæ”q ,ú9~dC»Ái¡Ì½ºHš~'ÿÐœ5f-dèÛ»Jp¯3ÒªDxïÄ'²)ílÚäšsF%°Sí=2ËÆíâ¸oDQø£À .뎡ALèÝ%ˬ’ JVñÓÈÖ.&ñ¯á!+"ØŒ&0õžA˜Ž{ß•Ö‹Ó‚@b—Z*û®$žŽƒ|«ÑîCŸ—¢ñy¦ZSHªÔ`¯¯Íû çãje›:³Æ%!ÎE›…b”‘…‚Ç*q¨ä矚ݒNï½–h×uœ˜‹ÿ6Û9 7ñ§é¯>~ÕµWmðrx}Ýœ‡Áñfy¨ýÙ_%ËáÔÍ€¯¾£€§}°nŠŒ4»Ü®0Í.“1$šÊ¼ûd=LÎáN«ÆXǾâ€QDÎ3ruáhI÷•ýpÕ cÞµÖ|›Èñél&SþÃ/ ñV0ú<&Ë5­=é Èó»•"Š‘ÕŠ¤MçÒo¢ëŸ/Ôƒ í&Úv›fé© çÖrw‰k‡æpxê$} (æSíZŠEŠàÍ#èlºjÆ̩½“Ì1{6½;Ç Ψ_ç«\¼*² ` ÿÚ* !MD%ReQ¢ XÕhñ6r<,sœyÕ‘ÞR¤rßÎÉÿ‚Ý%—µ‰Ùò5Zä–!ÙJ=®}äE\¬W¢§°µpµº¤uhÓI =;Û½6ÆêöwâòÚðȶãkv&"Òa›Ñ®;áŸ>3®ÛÍØÁÒ˜c‚±C–/ËLµd‘¼Ì¥÷ÓÃß©Ÿ°¨hiÿìv våçýxh¯õ¥»²aìü2ª0xJúãZ†»Õ’E˜½ŽÑÛgýFí¸A¯ˆDè°À˜1c±¹ÊÜ‚#á’R^) ß cIŃ0ÏZÒ&ûºî2ɤàŒÅÒ/ŠòL4¹}äÝHÊÍ[´†@Nò]er¼”¼÷§†¸ušV°sÉTeB‹ }œœg—0>ê 4¦QÇMáÓ)ü®-ûÜ-·XìMùTƒ4¸ž||%œ\ë;e£œ¾¿¬Â ÚwµjÐ<ï¨ó ºH ¤û€íÎ>ˆš&ð}·CB±mh!ÁÔ|ª·…uÍÇ·hÉSÑa8Sñ|Ï/£ñ^g(¿Ÿ @óM¢ð€t7W ‰ÚÇü;*‘—OæJXÝŸù_U—ss$‰} 5Ƀd½Ñ&–êa)=/\¾KMºø…±¾Û[-P‹X˜‰?w¶mÚ Q!Óð9¤zù1“9ÂöÉÝ\ –ýY%ÅË#ÍâFÒ}1ô/å»ñöfm õy´Ñ>¢Áiû‹AÍ|¹q¥ËâKëH‡e;žv Í>¥‚RßÞ%‰n‡0²4×mÉcu@‘Aei&Ù%$usà[IZ“íW®· £µE¡ÒÍ0œÑ—lÕ˜ï’dÞ9^–ÄH’h‚‚Önû®ütÜчG}‡tqÎœÏÓ×@zÆz<ü ?ÔoóBBz2Œ(§Pn½°Ù÷ž›DÕ¨¿Û¼*ÂÅK$@€!üÈY;µQ¡”K4R¸â8:!±ÕŽ:@|;6x¸ID9ú4[´æxö§yd¿QUÚ››‹Öñ›B¦ö0ÔÜçˆáºÓJÁˆÖ‰"˜obïb¹¯•!C!bqxÌ¿ðW¤'ßömmPuw5…s6ƒß$aI±ZúÛcYÏàˆ®pÆ_5ídNaÏÖ¡;é„M\í4ÐÃ×°´ &MÓ•8ç>®ªI¥­¬ÆqÖaä¼ß¥Öwšim_K׉ìù¶¢k^ÄòŸ,4pcî8~ÍíÝ]žûÉÊ¥v~ús ºÀbÀ¢0=4>¸ÿ£ÙŽl·þE³<íÛÙÔ-A[îältš¢Eð<@ÿY[I8Éšuçgñ›)ªîºÞŽ)Úz‚‡ ½dw6*¥„(’ª×2³¼·ÿ~ i²@Ø—uWïöö‚$nLz9··-3Û¥kdþÛcË} ü“þñÔôÚ^$ý2ù?øé…_W—ʤ¯÷po †#ÃÛe1)=éû´z[zŦ-Hø Eúñá²';2à+8 Cµ>/—<ßÅ^ͱ¹{Ƀ3Ú–Á ¦Ç'W—tö`%µÀñÐÙxej.áÕÏu[„”’JÐÅ L@jÈ•U2ÇâzÚë+6:œâóÈíïtÆ:TÓ]°”Sn6†G·Þ̉ÐÅÿtY¦3OÕÙB‰æ“jÃÞápàfÞ¥ü@&úê‹ýžf¡áG#<ÌØÓö³w¹3ý—ÏÄ`U¢å TÉm«!„²'Öƒ4uÓùú sýXªø‘ïBµåÖô9NÕ5Ñûh¾91"ø¬49Ïvo*Uì>$Œ¢.(Ì̾¾Òªw>ЯCLΙ»-í§•$6~-u4V,¢é)¸Ö;‘<õ©¿ôd¼·túuA1ÝeQ&t[æå†÷-ƒ>±Ä–¢6ÿõiKCrlus ŠÛ ±‚2@62y½Äœ)AkUѸçE Ü–Uˆ#k÷Û‹ù|ÓŒÃÖËüAñXe¤úþ¬Ã!ì™ÎºÁÇOœÍÝ‹y‹™8ž+5ˆa¿’ôüÕJjÍ×omÍü` ÉÏdV½ Žk)60o, q{Õòõ‚ZóÞ¯võ¥1ΆÓoáW…æs¯ãE$ݧñ SwºƒèáFW˱*ÃøÜÅA’J)¿¼é2¯ZÆÙÄòRËgÞÒ!¢Ë š¬Þùq7ŒÄBØ*肧ä¸Ý£õá„z¥+ é-‚ÎHØbú+mà÷óO”âñ:‘ïݧ–·gßßu,þ"ù·xnщ0œåVYè´–¦§æ,¶S{> ‰±Ô-ëÀ˜ÙG}蟛¿Š‘Ñ•©APÂ0T·±–uSE^ Û’ÝÝ3ísß•ÇÍm@c© Æ4žºè» aTT3çˆhkõtŽ‹ ©—i;rÏàï¬.µÒõ…\3‡ñ0¤é‰\Y'%ߢ#°Q5œox”×äTwa˜ ±cÔzî>Ôg®2PU;šAtoðð|®%½Ñ ¹”\¼oIêy÷5]Ìõ 3'éHÙXönñ¯ b §)êÄý£µbœ 4ÉazKQExshOõ·IÃm$›¤÷(áÕ®,ãÕæeÜcÅ‚þ¦£a/ÏfOŒ‚h9Å@´zÅ|2vÆÀù&QVóŽÜ¥¥ JþCªŠbE}¨´EfR&%˜›ç o[á–&3k³S‹K^¯ÁJñs×Y–wÊEêϳ¿aŸlÆ4N£E‘w™&QK”*bX±&"‘ §¥úÝë"TI«ÓÄ¢Cgx]oÝÖš±JÒ”tˆy0Óqë÷il–$qŽ±)¢ôßßIbÑ. Þú9*Ê. MAΛe ·âF‘">ºûudìV6zM)B¨<ë€:·ŸŒÌ6s¸oÕ´IMŒ4³¾6E•ƒ © zÄ1^O¢–rmð]ñâucñ1å¯W»a“m³ÝÒ¿>­¤©LY; Æ–D%¡b™ø Èg–ÛÌéZÛå]‘yÍ©´vÐmºa!Ìʹkc—š@æEî3¹ØˆŸŽ2%ºô9lûX2ü×' çÏ ²gbƒ­$šv½[‘Hê’Ò_v‘ßkq}ïlÏvðBj;ZèƒÓû~þ45ZTNdÀ"ܬ €Ä¥^סlQK¦æ%èRÁ,¡ræ|˜ÝÓG&ÇøÞ%ùдeÞ0m Ê=v¤ºÿ´ {fæ†)jäòã%ÎÍò—C©G“årpZ †C8íEÐŒ;xL"üáIž³þ¢ £_(®Bs ŠH¦K •ÓàáÇÕEâø5¡¡†ò‹Tbî¬'FÝß.†i|<\>/'š ŒÂ_ü8þ†£Ž­Á5‡á­©’xõÄ«zÇÏ„ù_˜²e@w Y e-Ó¯)PY)zK|ÊÏx ó[ð{LjRN¯Pbß[ü;R‘ÕŒä×Pu&1QvÇ6—.À5§ÁOÜ;𘡠Dbç6f¢Ñ7Mq‚­ElŸómÀQçaÒN ¥¾a>ÑÅf–Þî68é)—èb|¿Þt÷ŠÖ˜ñ¶âê÷™)Ul@>ä<^¶¦g>eõˆ!) Á(ÙrC‡ûl 41¦DIU}I_¨7ƒ†‰Ï‹ã ¯ó¼ ³ÌŸ;Ô5wÞ,+Yɽ¥¬×£¹_J‹Šr:¿ØVŸý ¤ ƨ†8ÊRßÚåñm#Þ‡ìN)ï¦ÞòYk¥ó¦ö¤aûwD­à½Ë¯%Z„YðP›wµ‰O’pe\5õ;´j½ž±0h®z¹Úäþê¿[ Wü±rnÅ:ò\õïÉíÙûºvWæzb:ºÈ¦½“•T!Ì)d'8ÒÃŒfx.~î Ñý/×»9xÿþLü¸å^äR‰xL²Ü«ÓîŘtqS |BÄEöy3…^qÞ6ÒB0]ÎõÑèÿõë9™ endstream endobj 3714 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 3720 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 3724 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 3726 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 3728 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 3730 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 3732 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 3734 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ÚxT“ÛÒ6ÒE:R H¯ Hï½÷RC€@H„"½HïM¤)ÒQÞ¤I“&½¨”/z<÷Þsÿ­ï[Y+y÷3ÏÌžÙóÌNVX™t xåìveŠ⊴ Ì@@(È °²BQ0Èß8«1Ä EÀÅÿƒ¡à±E¡1E[š¨…€Ô=` $,@ ØßD„»8@ÑÖjÐâ¨#à$«ÂÍÇêè„Bïó÷#€Ì ‰‰‰ðüvȹBÜ¡`[8@ËåqEﶅ `(åó’N(”›8?¿——Ÿ­+’áî(ÍÉð‚¢œú$ÄÝbøU2@ÛÖò§4>V€¡ù—Áá€ò²u‡Ð †À‘h¸=Ä€Þ` ¦ ÐqƒÀÿ"kþEàü9ˆô¯p¼‚Â;Û‚ÁW7[¸îp€Â eM>”7Š` ·ÿE´…!h[O[(ÌÖMøº-@YN`‹®ðO}H°;Ô …äCBa¿jäÿ}ÌJp{„«+ŽBüÊOê£Ï݇ÿOs]à/¸ßß+(ÜÞáWönüFpècˆšâ"ø7æA„€bÂÂB ä1â vâÿµ¡ä·ñ7Œ®!ÀÏ áp@— €:@Ð~H[Oåî ðûOÃ?W À Fì ŽP8Á¿££aˆÃ_ktÿÝ¡Þ Z~ ð×ë_O–h…Ù#à0ŸÓ·˜_ÃDQÎÄûOÉÿ2ÊË#¼~¼b^1a  DD„ÿŒ£k ý“ÇøªÁ±¿ÒEŸÓß){þÑÇŸáü3–6­\€ãßB‚Ño ÿ³Ü»üÿTþ+Êÿ*ôÿÎHÙûmçø‹ðÿØm]¡0Ÿ? ´r=Pè)ÐB gþßTÈ_£«±‡z¸þ·U e‹ž9¸#ZѼ ‡|À‡áP¤2Ôb¯ EþRÍ_¸Ñ¯yƒAá]úë†A{ÿeCØ}‹ ÑÒüm‚ gèŸû*ÁÁû_Ã& $ °uw·õ!@÷½øÐSiñþ-f?B»Ð5î¿+à·E¢k†"]Ð}púeüƒ€Â~;[÷ ¿ã¯;âyìn׿ @? â?Q4è …{ ÿÈìáîŽßßÒB—ó÷ú÷]xCÀsÓ°D¨óëж‹9:/ÞaÜå•Ž¨³žH!ÛÌ ?'M¼,•‰Çò6öU÷ÓugËÂǧýé¸.F¼½Ë ZJSÍCa(õ¬Éñæ÷?yça´GÐ:ŽŠ¤G­‘&ê1ØX`[°'›L_†‰t n¾úRxÕÜ4Û¸ŠÏH™ÒèP±r¹»˜Ï̘XVPfHãÈÝ-2< ÕŒF¯0ŸAãÎåÛbh¾û¬YÄe,.~ÈéíI<.Ðè®® § ¹ë«Î”;˜ÔGC™˜£þ‰Á&/t¦P–šÀLSäζ„e#²ôs² ·5±OУÁQ[!èŽÎ“¡F:„дTn×Ò1½õz¶áw~¢{MIQN<5é,ò¬Õög‡Õ‚°¼nl*Fn]ÇüÖ$¢¤ôÜLóSc Þ“A«/c÷.lb³A–©R0ѾÏ/å…uaŒnƒ&Ÿ.%S´¬ºjXÚLÎ+ƒxø¾½ìV˜ÞO†Ÿn5}hèŠ8B°0PN%˜¶gí¾ßI|£&tö‘̘KIU«1ƒè´æŒÏŸ ÔÏËÅÖmíP‘0—›cŽ7$É7$›1ÔÜÄÈоm&&÷t’”˜Âå ŒáÕ§Já¡RÁMR©¢OOæÇŽn)êíÅ“Ö®ÝÑëúŽc•`ç~Ä/€o¥‘×aîdS¢Í®Žz˜mÜM¸Ü’7›:™^Ê“¿6 ´¦(}ò(Ï!ögÜ·ÍÓ†ÃïÙ’»—$ÓU—r_"%§VjpAš'´w­¤¢ãsÅ÷ÆÔ,êqý}O}…ÔÙ"ì=E'âIYkžÜ>ªÁ’vrªX;ئœÚ…®fy]¦×\E±½Z¿ª¯ ø\0ÄûgctОÁ€‘®ZƒŸÆHÙ0’6Œð`جº-ŸÏó]ü¨E~óÏYÆ&MV|ÙÝLÕðdrÉ%]ö8õ—ƒóž‰S<½,õÌNF%Z2§u»2+Én\Ó¡"žÄ3ÔRóº dÀš I²l¡v’Õ‘`j”áF¨CK8€ÖG¯8"¤Y‡3´ž¨(2ùe‚•8ìv¨ aá$}ß—''Û~cVdŠN §’ë~™™«ò©ƒ;Ó?ÞöÎå"ØN|–Vk¬û^M¾’µ3Š&×ÂiE³‡Ð|¹¥yùÐEGŠzÿºBvÚTºãYÔE(=[¢þâ‚ù1“‹Xÿ1–Å'&ܽóoFf·&!Zƒ­fXÞ°Ålœ[’‰ÂRã×ß ›ÙBCßñ'¬®Zqf1n¼jKt‚¹Ry07V·BÔnÀœ/¿•zéa…aE 'tœ),/E6_à ŸÏ4\ïʌ¯mc?/£°äÇæ ð‹ïí—Í›Lã~FŸ%¾uU¶qƒ÷ϯÕO~žò+'Ò. Æ8tbE~/ß>Ê`4ϬhR¯oTZé é´-˲<Ý’™â!ÄÜ?¶CåÃ’3œH…ot"=»¬Kpõ·‡êÄ VXºûLznç·ß%Ð7» Ÿ·½“(ª3OÛêì]÷œes!ô!‹£jPMòq“ UìŸY$;ÓìƒrÆÄôC-+³í|Ud˜Yƒý!‹E^L[µiñƒEúº[,_Þ4‹ß´äìoSz0»UdÏ^Ù½ÑIÇÛÜHøAƒŸ®Àú5. b®“.fvšÐu0¬Úü’ö}&±èèÛÓ¹XðàIÃ(âîfet¶¦jÑÇ…Ó“Æ\ÎŒoxs¹gæÁf>©=íEyÙ·(¬µ†b®lxeëð€äƸWtì§9£µcge(ƒÒþB{™ÅZSJl Ž³°÷ç.Ú& fo÷•g%·äêÒ¶]êæ»ñ–õ÷9>MZ ̲’1å.¯ö\C[1bFH¶aþ®!ˆÉ{eiô6Z(«Bó}žSø'Çò¼O~Èý$¡0ñ}ŠR8îãë9¬$­ÞÝþª3ª]ÔlÖ¥*$+|NW¡~ÛSû`“YE8€°xè//ײ”/Gð6&…Û³†c½Ùxêër´Ji%L$XÃÎä®ï’{žõ¾ÔOf?öò‡ƒá¦Z€bŽÎ{Ý©µá‡4¾ü us¾šÝæ¡þÍQŠ·{ò’|_*í»5FÓšüh:‘ë[‰¨Ä¬û°B3Û$·žÒü®ë¨Q½Ê·À0 òFŽh0„éFqÕ¿€@Êâ‹Š;0¼\>EÜc¼PqŠà—ÆC™cǺƒY€ ³×AõÝÆ2ÐNrò(ß“MÑÞÿÎ"iûgìؠîc×¾/é+4K†hOg߶dÝóÅiÝ0ŒTX äzÒ’Ø“ŽS‚`àÚO‹éuR{–p®6Ú×8£ðvÎoá»Íƒ;|Ámª™~ý•°[-¦¨y¨gŽ%tÞ¨Ë Gœ¶·³KŽ™µ/ãBx÷@üÄ1y"A1\JBÒí#¾"âÒü,Ê¥Y®±”oû:2Er½D´`Lâ8GäÕþ´?\4\…8ïÑðÒs\ŒuËáYQóMGG>éÚ­%Ô4Žzrúáæò•è.Ìv„È’õîs±MBk™õ+½7Pú@Úu··g=qŒxxÈ$L!>Óx,ú‰áWœ_¿ÐæïcŸÙƒ4ò \**†¢+ ðéà@_êr•W +÷G½‰ßµ-3ÑÛfõ ¼§þºyÖ´¶ K¥æ|ßñ’{òATEòƒB†ÅJƒ“Üܪ•¹*J¿Õ.exºëLÚÀEàw É&°ÄB¸ªéöLÅ¿ulJ÷µe‰s /i28`ÇRv‹%±Ù&9Kp3øQ¶#nsŽ}’Krì®ÑàÚ 2ÕèÂœ7nd÷3?’cøÄy~p6z§nÊ°-…¬;3a^sd™X}÷ðxÛJZzeQ|$Ž”|¾Ð$ÐÅôõî’QÄÿlŒ´¸ß…ŒCwÆ¢wëœ_NøKÝÄd¡Ït éøëvãn!³Ä¾–0Ƭo$s0p;ºÉ=å©áy'åï\! D¦Ð,’ýmŠ0é0­º!}–ž4o›_¹”Ž®¿yX†ÒÏYi‰Æäc¦÷‚:ÑÒtë>}YŸvu;>P@ÔËÖÔ®¦ÝXíÈM –¬êQnwÊ3Ÿ>a9S*h¡Jp–"xf)¨Øzîç…SmM"$x^¤|à8ÙY÷ð¹|æÖzöž\iùJûã×£Gƒ$÷—ß.?lÀ‹fŒ(L;½Òu¸÷ñvå Ï´AOžðéZý ÷‹ÄÅwž6Ÿ ÛjÆRŸvzŸ«°ÜäÑ…íŒòä7ÜJySJ½0Ú¡<œ™®©ÍJ –ºWõΉúÖ}®Áör>\þM/Ü÷Qú¢-²ssϲ|‰ÀMí²ÝÚlj®é¹‹/¥M™>¸¦B¾ÈŽÀ¨ˆMn˜'ŒT·.ž‹~t¡žJÄ‘ô¹ÈÑö ²MÁÛ)*mïá+î=ÄDi×½„ ¼&mr‘S³Œà¤Öº l4(ørc–6o  ŽÅÅÍŒŸb+岊cèKd¿Ëb¬Þ»d{Óï/¹<ÒS˜~ÞÁ8N»_C~³3WÎ&®zÚ(™ÿćÝu)™i´$æÆdÝY¢×öéÛ:{±v¶Jýá N†41fOéð[gËzrø‰ ©´z¾¯ÌœâþS)í‹°[ívp"†X¿ÇÔvfÒÌs¢\[Ï:ú‡]J}/«Ñ €§'Qªk]DñŠ^«Í–…O Ûé(wí_ø)%Qu?ó š£YÉ$ãc¡4^Ùt¢Eåœùº°¸¸°X>Ü­¦Ä>;4åÿ¨&mUÀ6I“=<ù)øü,Ýí>L¯úE²Þ—Ì(l»•RJ~·“[ '/è “w(‹b[_OÉ‘%uÂw)ô>âݸjÄù±ùJHNuæ⹯Y@E†F©êws^~e確zlúÔðü%I7ãrÌ/S&àJÙ;8êpÚ\½Ÿº²Zpáó€c­Ú†õ“_9i S›c? ¹ìÝ|ê°)_Á]9åþìPiùÐ5þÉQGƒ>Vï%Ë–×Rwi?ÏäÈìØË ‚9I-ËiÓˆw¦è§0X¹´Té»i3·‹r%ì_®dàô»»µÓÔ€î:_å)“Ñ’vF‚à ¨Ô}öóU…Gi-nœØUœg¸×9Ö÷³È 8k§8šd5ÜÑÒj!h¨ %zÜëÉÖX=p®°¼!¨Ñ¨iŽ¬ó2ÔõðK¤B¶µŒÖ\èæ>ãæ}^U–oô,½Vù›Ñ….s«ÆHx8wEÛ„YD„BXÁ‘z†µ§£ËÒ¬—ptÁ{GÎa¦Æ›³yõí@ÂfŠró‹Ü¾ªxý«+fª v ä†ÕVÕ>¿&¯>}+³ñ,b‚,Ê¥ÓTçŽieÜŽñ|ÆÓ›ïê.±*KµwõõÊGàžÍå«hÌê:Õ=Ñ®·hÂV°Þ‰|ª€dHå»4áp{ó¶ädZJÌeÐ-›‡èoe%д:{ÛÕÊ"‹M€þm\’`¼OJŸ’­j ¸8Øž <ÔEŸ’îÔ{®ìtžjÌ›øåhM. ÊÌÄÇ–i[~7¡‘¸Kæy?!Œ4ÇtU'Tþ~Òí¨SŠx>Ý5 ™<&ÃÂHß7Hª=¬3#ËõW!IRã¦Ñ×w®’„êßF?uª…’ö‘ªçZ ²SÀêxbEÔŽê¡“s¯Í‡±7^ô§^žÜztz>›×O¯„¹’¯›Ì&‚B‘`žy¨øJh8>üt2Ë(ñƃ“y»NâÇ‚AjZ—gûàÑå7…'u2ê!­üIÊÌÂF|5@éM\ÌSî ½ÉP óÀdŸÔnÐWäöÒ~ˆ7BÝre¦œiÈëRXg‘/àYîSÔî` ÙQñê`Yw%Yћʪ·— "ÑuFÈà¬WÓe½>›ï“ñ ób„.UÜWpß“ ±ÄG¤Ç°ù×Ä7tFã?I]T)_ŸÍMß!ʯÆÕòÜXæp¦F•„¬-ˆ¾ŽÀ¿îg[ŽXöèa™Ü Ó™M¤t%æ‹yWut[ߢƒz,¡-éüà þ5{ðæû6PÅ,ñ[‰€û$Ga´Ÿƒ§9Äg!ñµ2gaákæ™5"#°Ëz¶ »Ê6I(dcr +SSì¶g̬½þ6zŸ >¬{(†ç$Gœ°=½z/*Æw5]ÒºiGë)æTêä–!ì*Ždƒ‰š6ëJÁOo«)oŠËt¡Rfp ŒtFÀ½ÄÎ ®EŸ+tD¤ƒ\L~¸”µcšV³‡¼>`(¦Ê!¡ì’4*y=£=/ª‰°wžGÎ ’FHf> £ýš6Žb7Mµ§ãV©=Ò^ÇÅÏ´õë±<Žqm~ÎAs§÷+inëLe‘=­'Í33Ìp\³´³ëû^7ŠÓíL¦L¥÷ºÏE”e÷Fß;ë’ˆ­W1g¿sL–~3Ò3§{w*!o¥¯S–,ø½“KþŽ`]ˆ¼‹åͲZ/ñÎMžµ.äÚæ#Áý –·Ë6Á¼b”züï‹6´ê OsefßõõïLÔ4Üb$ÝsZDzŒ.¶;ê¼}µÝºSa½# 9~1œÖËMº‡¢ï*¯±Í©¤QÏ¿.Ó‘-dÕJT ^Ú&B7ÌzↄO=¢mæ·[ï>Ö2V¦ ÝŒp»¨m˜ˆI;¤”½Ž]¼o<DE4VÜ´ä;—‡wû3—Ô9=H˜&Èëë· œÔŒvÊÃŒ3#§¬ãœE‰¸P._'?` ÄSMz„ÁSé=⊬Fzï©æJ*k­­GÌâ ï;•Üi6»†áʳ4îdÀkbNOŒ5¢~ýMÍù€Téú‚—öÆó:[X¹xË…ŽÐ²îz¨W·õX”0šIcI0jlÙjcü»ããk1`­ƒR/‡„³Ôõ€x†/ÛE¹?¥0¸´}[çû×]òü·¤ ¿¦åR5aj…4+,~¯šç®wñ* >²¼ÒûÉ8® yZp’ØDåáuûsG1C˜rÓR6ÑæÐu¥déápÿF l’BÏŸ¬÷?UZ샧q-ƒ!˜ÑÌ*éF´Î±Ë¸¡>ÑG(Oï)q{½D*s뻯 홓Ë_Úqo¾Ó ·œ…U{fö:^6}­@Ú©¨Á¨ƒGó.Â!›ÃQÖËÒ¡Ø8s°Ëb'ðÉn Hùû6£‰œ gåí¾UlωjúF[ž„¾?6 ›–~ çïÚ=8˾e‘íë3š4Å‚ UλL ¥ÛëËíÙpô„Éú%Háø˜HwE®KÿH¬Þô‘ýÒsÓl´òÿ÷_ ݪ}`¿´#Iy;‘2›w|ËŽlYÄÇÃT|^û|ìùvõG]Ø_˜3ÏÙ=ü)™¤çëc©»Û^ZM½J¹Ç9•Éë÷F'¾¹Fgú‡©~iW=‰÷‡­]üû‘z=ø§^òŽc‰«mWW­¹ÙÌ3å°l»£3_‰æÚ 5Ÿ©GJ38ïw¢ÜÜK]´ßÈâÊvAØÞ¾LÍ€uD¡ ο¼geÚçÜâwÓï»Xš{[Î|O Áƒ C ’$tÁý~®Yb~ÌN‹·¶¹ä[ÆçM»H½×´§G50ò<çž3@ ­/ž' éÒÓÕ'¬|¾´ïæG‡n^®S)íàñ¬AŒ&Ȥ´¨œwyƒÔÁ}ÆŸ Å'hæÆ›¤ûA‘3’™I:õLZ^„è\}O|È¥ãû³…Ütâ N©0c»\^˜¥ˆßÛ‘Ú!O1»—Yvñáh‡GN> ¶¬ÊŸ#s9¹Bdi‹ä«×æ¿V˜jÅ$FQ/\©†©½ vbøé4lßs*ñ·ƒ€îŸ+ÔKUŸ&âbjW=ê”±zÈ~³eWÖß:zÿ-»¸Æ„—xÔ"-žiaÞú†ðL5ƒ®æ"º9v1:<ñäšÁ/­‡êSÀµj§«9 ‘ò9aiGd ¢c91O/·ïMÇœTz!Ç\§°„ñEht²}‹½òT'LÀÂ\‘qÇÿˆÂ‰Q]Ï_žöÑs¬ºá»¬CÂ]믷ªÕ9ñä‚©_svG•¿=(¹Àh ˆu‡/“¬iî%ëd¾ÓNH‘mPòÝTug)³çðo9×À…ë¹€‚*w`âMEf·°UL_WÄøM ¹ZÔp2(œI¡Â% àA¶Ï(êŸb n¤×ÙUиÞö!¸¯Ø°Ws‡w÷”«u“õ–„T;a5ÊN÷JG6^§¯±#7Œ ìý¢¡ìB? jYy39­”m™Hõ£ŠäD¯µe™D%¢W '†Å$ÀñÁGÁ_Ê:Ó3áÞÉ{ö‹wû'û›y‹Þ‰ŸÄkº™4ßHViÁa4O„]…ôiV(¦¦…Mm®©®gN­OÓI‚䥑 ©— êö‹àóŠ{ÄM7¤ß´,N)qSœ´z/t¶ê‚Ï( ªD)rÎÓ>ÅîÍ}ÛäÚ¹ÕjÃÔD^d½º2LmL»‘ÝÕ罎½­¼£H9tk¡R±váQ±Tîé¼é —y ¢(]ŸÁ·:Üáä=o‰7[c];#_rÖm…9¾ÅòTèá>Xˆ¿8¦J’ Î>ž‹n´¶£6úµ¦ÀCmƒü´»›*§xÖ=ËuVVVWa/ö]þˆ°Óïd;dL=4Jž45LÚùp£«_¿GxëI}_yð£Ü¢•½²¥ÀszùaFãAq3¦“©åø&ד² ¿ ]}x&©þã’IbösQ®?×z 1Í’m‚6þÿKrü†ámÒ¥Ò<“Öð-™0IÉ­qÙy¡~›£ébr £{mùÑÚÂó rg939‡{¬;Ô‹IÙÞOrŽÛ¼D¥‰ÛUk.NûѶÇ>ßÞ„Þâ"Süœcîy%Ú«-½ÔöØãH{Or ?P}ÚÓYêÞ Vê?ëµTëç¹ß²–3[üæ®PÍÕí^9X5ë¸çbHûC¸•5֗ɵé‘Íß]eS<Â.ÍÁ %å{äŒáK<$êT‹Œf6ik ËC‚)SÇ—ÏÁJý³Îþt‡‰s¯ýâ°?k @_rïV§Ž^Nëdš`úè«Œ3úxžêD“hj”0:=ˆ[&:ÿÕC»y endstream endobj 3738 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 3740 0 obj << /Length1 1455 /Length2 6598 /Length3 0 /Length 7603 /Filter /FlateDecode >> stream xÚvT“[Ó.Ò{ BB¯*½÷^ ! $¡ƒ Hｃ€€Ò¥H¯ŠHPšJ¥£4ÿ¨çœï?ß½kݻ޵ò¾û™gfÏìyf¯ðpšˆ(AQŽ0u+‚ä*z&VRH‰‘ñð˜Â±î°¿`2sG!åþA ƒ`q˜*‹ãé¡m/wX–’KË@1Höo" -P…xá= @…„aÈxTP~h¸‹+·Íߟ~'XVVZø·;@ Cà H€ë Càvt‚¸LPNpÖï_!ø\±X9QQ ¢Ð.·„>p¬+À†¡½aPÀ¯‚úìOe@2€©+ó7A9c} h¸Ã`H Îà …¡¸Í&ZºòY÷Að×ÙÀ@ð?áþòþŽüí qrB!< H?8Òà w‡ ÔuX_¬0‚„þ"BÜ1(œ?Äw‡8â¿3‡Ô•Œ\•‡qBÃ=° îþ«DÑ_ap§¬†„ª ‹!û•Ÿ* s»ŸèŸÎº!Q>È€¿Îp$ÔùWP/Q3$ÜÓ ¦¥ú‘ýsa’ Y)) iÌóurýÞÔÏöÛþã* ð@yœqEÀ‚àÎ0Ü‹,ñ†°h/XPÀÿ6ü{E p',ÀæG’ý':†9ÿY㚆ûl@8í _Ï?_wqò‚¢î~ÿ¡ÿªºµ…º’ПŠÿ±)+£|"Y œ\ÅdÒ2R€ G1„ÀÿÊôW-¤3 û'YÜ)ý°÷_ýçÿk6ÿŽ¥Â‰àÿÆmA’ 'Üøÿ[é¿]þoÿåÿ¥ñÿNHÝËÝý·™ÿ·ýÿ0Cpw¿¿8Ízaqú×Cá¦ùßT ØŸ™ÕƒAá^ˆÿ¶ja!¸9PBºà´,–‚$þàpŒ:Ü5„c\ÿ(ænökÒÜáH˜! ÿuµà¼@ ÿ²áÆËÉ w}`p²üm‚á¦çßûª!PÐ_c&&)€ Ñ?2NMb’’€0n¡0ßßBˆ‘(,΀«1àŒB“ýj«8@‚ÁÕ Ç¸áºàúËøƒ¤¢Ž4ÔÑýLB GâÆ ŽëÑß  Š€#½0ÿb8ÀË ÷pÿCúWºN^h4nj« WËßëßW æ s"›F9É?ºW÷¨ý{­«ÈÊÑârgT¢U_¤$–÷ýãW]âl OehÕµ¡ ÙgáãÓ¬‚_¿úÚöä>XH×,Àâ©õ}VÞ)øqÐã»E]wy+õ™ö[’;µƒ ¡ _ŠÅôy˜t¯øZõê“‹NÌšµì(=¦áLgÅÆ)åwnáÇXqÞ\ÆZÙÒÄÓ¡m2½LµÌÞ^àÇÀãO”ÛcY~ø}¶‰ÏœŸ“ûº/C|¿HçeTU8= ƒ¿6gþPr? cR®vWYòXåYZ"K "œwQ7 fc»ÿŠ„”±ÝR‚G^IFk>V¼±}¯Z±]!i1ýôÐ?mcc,Ï}‘!êå\V˜µÓE‰OÀ]z›Cü“J÷m’Ìqf+8“z ÷Þwÿª`£t¼œñ>šŸ[4-rÞDììE"-|¨p¤qÈ€Èß«S?¢®‡ˆT'wÍÕ~yüØüç!_ëœ'‘ó oŽÏSA_dý&ÖúUõ4]Nóî‹'øRÜ÷éÓÛ+¯"¾k,§v³ !z”i1M­ý¶ ü¤æàù)Wàý«eª±£šÇz—aSÒĹ·­%Ÿ¥ÙêèeêÛTÖ•b¤ž.®[ÊQGŽu<• {<¢µ¬ ü¢Í1ƒR) «5³³]£]Le[ždý6O º+ÔïFÙN–– û'Bð¸I|\Uš[U¶.a+ÆÄ‹â虾láùRš”â¡ U¡ˆð¡q MʾÜ觡šg,uT_s9ñèÒ¶eõÞ0 c" ‡×º* fl74yu·—í»§®E@ÄÎBúèå™wŽd„'yä$Ÿ-ÑÿB±…´1Ÿ¦mRŽŠÿBÐq;T‚Qœ£ÁMU¸’µk•½×}sîÝÙß_m—=Ë䩺H2~\0dMP¤°ähà,Q]k.õºsôF¥»——Cî2è(§ë×vªÇ}|tddJ‹0¶½þ]=µ+YâôøN‰s‰:j‹J4hu†ÎÉ:"ªªjç™Kà­ƒ¶E~ ™ªSš7 —²KCãíµeÓ|`2¶’7À¢~Ê+Cì]¡açwŸW™z\‰öË|“ì˜vn¼,È ÔHѤùB RÊÞÂÃ'¥·±w¥ç¿Â<øÒø<Ê#€žs—ÂL›IuÝŠdåç¿&ºŸ•µýÎiƒ¤e•\Ök¡{‘âRUϮҷì)ö»?ê±`òªß‘°Äwý¶æ9îŽÕD“,·Ô¯³ëxÞÓ¤ µ½¨ƒªæ<âl¹ç¦ ­Í‰Vê¨ä-” =Ö¯Ý ç”ÌÍH¶UÖÔ _΋ŸÒF÷òPàý,qyQj°:•§ ãh4›`žÓ¶Ç±itä«z˜ý¥ñÛcšÙ|]ê÷74‡GÛ£!óœä­¢Vkµ hxÍB¨Ri¹¼øtñVE´9ååËt-vDø“xeΠo'“OW{b¼í%²ë˜åUéŠÊå«cø,ïô9ŠÛªK0LãÌ¢(hn4ÀmÁ? ¡¬h³þ6;¯^ðz÷[‹ðFd´ÂæÌˇ9äpš~–gX»ôO†j‰‡\ÅöM‚X'Ê5§çníØ¡3Ž5CÙí½¡ô×P`\eÓ¬öfÿ]rï·6–£×¾Ë8º¸Ê¶qXý1ZJ¯f›…W§Ð Œ#ˆf(5«–@4•áY”0 ‰‚²hv”…÷aÞƒ‡üYßKž>zÑ5ÍbÏe^m³ßPmp"x8®ÊŸK’é"üh;a:„ùÕh÷ÇæˆBq©Û ÷b/È„%k%‰v‹o…²õ ¤j0|Ôý™¼\-¥ºé{îv?8©f*ŽúK¸@2÷{Á>“T|°ê·{/MÎQÚäøÞ¡f­í!+N»&4\ÀïhQÇ3ËMºYÄðÙýV%X‚`àý“„ ïÄ ¥UÉx8šT.)J àëé·õâ3—¸=“^ø‘É]¥ ÎQ%¶C²öë½ÃyßTë† >ÊH]㺵[®ü¡°ý¾{´ ß)s/‚c&uTÀaß•6ö¯„6³å®H”ÂÔ-CRoM;LJH¸É§½;O£Ó¿é }ö"#ÓŽ:µ„^×ùgáûS¹Ô˜ ‡r÷2:òW Š×8ûÛóí=Ù½§ƒi>ïG,#‡m…RaµDå7ëUU,*ƒk®r©Ôš~~³‹U8âëzOœ:èÅ»=´G6Sͼ®*ÆÙ,„Z£¦P¸×:¹Wxž¸3ùˆÎŸ{_U7cÎø%-µt8¹'AŸÄž˜G¼ù=39$âdùfÑ<7žðR ¤ìñk/uZýóí*‚ Iÿ¾¢VÚÆ%!êbìÜbóªdWïÙùªªNœk}‹Ð8ÝP Š®âîw´%]’ñDohMÅÕý4`[Lí—/J¸öÆzŠc.ãˉ0b¡ÉøÝ>pŠ“±"Š7’ 2i…yÚú0)«AÄD¬R½Ú·jøy»sm&<ùg²xŠOØ^ØZlRÛ’_µ$zXq Ä –šë0(â½{l†;Få¬ø$°º1¯Áí–X ¼èr°µ­ÉÆóÞ\léoœ´òà~µ2&9¾^oË'8ÿþTZ¬ÝN›X¢àæþU åBÜüK÷YÒ1­+…÷9¨"¦Ýʲ‰°<·¯áK>¦±›£Tizï.Š±ºùÞ„É7¾{šX)…¸ºüÑ9>= ƒ×o}bê.2{ôøÍãUöЂ ¨Ù×-¿ˆòêºÍš˜o±Ÿ¯ûó"ûº ÒÏ©ºBtÚWÈ ãÇÆ´ª?¥uL¨xó¤ ¬Ü}(¼ÃŸÜ[°ž?GæÉ ò˜P°VÝŸŽq©Vçú%”ÀùüK¨_æ­sÒ\•€¶2õ¬‹V¬œzk¿êK¾?¨$—g ¯dêY;7]žócöQâ¡ò%T. ¨ö~÷V¥¼ÇÒ4QÈ`•çÇÜÞt±>”C*qOòªv= Û¤» —¢UÏ»NÍãÊè¾Û”<Äa¤ÑþwHíMú¿8ëƒöŽŠ?’ÈÎWO‘jq‘ 2QË•½ÖbŒ(òþâWA}2r´—gý^²ò€±0i6ÿÃøFTe‰<¿ÑÊ“}ML¸¤Y“Lÿ¥àfC¡Ü£Þb©T·>ëëª#­5E½iÛ¡¥å÷(ÁÄ0Ä›¾’Ágv~e Ñ2šn H»4ÍÏÌ­S–ÅÚW<™¹š± |}×—íT§^ÏPe›AÐg–zpµ½Ôñ6ÿ€\·‹R¹'q´ ÆãAŠv5è­šR¿ÍOŒ$FùûI<095~“ýZÿûpÑôÂÍ¢Ëbì”úŽg^P‚öI#oëtŒDì)ík{–z©z!Œ¿ã›Ž—ÙtT Ó<É£Ò²¡r›1k Uúfé5~ÁôsRצÍü”ÉÏ¿so’ÊfØ}pç¸AäÙÐÆÁ9[,;„‘îè_·×Ê~x `Mú­&™1ê ›×‚y“ø)"6ÏOþ“Ìê$|v/àçH|ÚSº¬u¥ÅÛ?LÇɯ …zôäP[“ÌSBïnxÍóZt)Ì,½±¾L¶Ÿ ›^ƒÀÇ$–´ß- Þx÷*WêK»ˆ-˜ãøó£.ëOLðåÞ·ª’dȽ±¥)8í¦ÅDíò6 Õ\X<3÷bþ`{L zG ë¼O•à ÷ ;Ñ.VÑÃ-rP %g ŠÑÛ¯¯YÁ8 h¾wü*¬w£¹¶ƒ_Æ%Ë;u¹#ÀAÑœ¢æ)ØóàùkÕ‰wâÄ ô ¯|Èc`îªÚé:®’—AlTñ*ÂA¶ßŸl®ðÎÄ¿¥¦V?tñ7ÔŽ¨=N¨Ü‹[¤ýp)íe>XžOS?§Ë0Æ­$™ƒÍi½o¥Éÿ\YwBï9†„ªFŸs3¨Syó„ðY7Å@Jf-•fÏ7£Óq‡ø 2YnqK)«‹üc›^ó5Iç̤Gx£4ùÂ+\!uµíâr¸¿$d²Ú…’(éîP¶S‹©÷!£¹JËJíu¥0Å ¯ ®êæÚLõ”Éey} ‘öA’u¢˜¢­¦G|Ò ¿µ~™NËá(ÙÀbÚ´xEo:9G„µë $ÕsK£LQ‘Ûb€O)\»e_ ž»¯tÂêÉ™ã¡-›KÏ+Êf×ÑÀ[×YBXíˆú· bÏuŠY3UNæ‰fJ¢ßŒNc9}ž„å‹óéŸí×¹¬çÀ„ùUs< ÷O ¾cglÆ †¨†zNNåý-hŸ5ì0~o8¾m)3õWÞ9Ø0E/h\äi«jË'V}?Ý.“7Rty%òý,eSïð"³©lĆ›9·¦,CXüóJ?¢·L–t cã‚™>|Þ÷ª¤¼Ø!FD\û’“»_Mw½ŽW;Ac» ]+þЭpÓX´gÛŒ´q¬ãÓZÎ:¹ƒÿöçÛž^ÝOß–’Õ³ Í×{T²u©ÖesÜ>o¦XödÉPŒfš—ûh¿lâ2௠ëô4ìÍ5žº|}‘Ûy›×(Ñ÷¨[tcòÄä{+Qe·¼áàMç cûø|Ù®YÝÎOéÊv ævhq9›˜ÚÒj±é ›ž»xi‚ãôKv)÷G˜è—'›îŠÍ¶ñ|•mˆ°¹ˆø‘puQWÊ#c;¶Íæþ’c‘˜ŠWþx.w“kÍ—‹Ô±‘œ¥»Z!’N ½þ)Fj\áΉëñdP¢^wä´‹Ó[‹ù•GKØ ?.š×ëzz¡:«éßðJvŸYßüÁ:€Y¤’cå¿»á—&*ȵxt#Š"É/Ü? Ñø.v8o¼K³â¤1ä5ï×=þƒcOŽ†'˜ ¹CønDKd뛋°®FŠ¡+Þ ‹ìè[nd=f›µM{¬Û¾ŸL*ÛdX"š'g$ü$+ #ŠødÒnƒ³×™…»wÞ +‰œã;ËŽâíLê×ù¹Ù¾·¨,\¸_ܘ"ïrßÐcàŠÜç‹[eÊS‡M½¿Òñ}ŽS£K#0\4ºNvK›@‡ÅÆUõÄ78‘ T*ñ$Å@ !¹áQ¼ûBý­ Ï·[šüb#olòImÊ” ‘w·ès>–)þÈo³gTÔ’•Ê*qOšPJ}i†g®ïG±§*Èpï}­ß6Ißèéiêðô´bó$ÈV—¾Ò‡i#ܾR3&»Ÿ:š¨ °ÔÄÇÅÔ-Ö «?.Ù‚=ñuçXÙÈ©hB®p%]éLð¢ŒçÝMÕ¯]»òñv­Z€øÔ?ß³ö‹,y¦ZaªwŸ“|ÝKxp?ÄçáL?ÓÙ”Öê6 âxcÞ+&Õ²–Hi¶œ[gž´ä”ŒA'¶äè³eÔ3«ô>Q"²Êe%‹±ú¢FÁ˜E“³EsîDüÙc ÖRá¶Zò=Ùý@c"¡¢¯‘mºª4Ó.Þé¾Â}»™ Ù4ÂWX,›L%J¸Ã}=cI_=ÓÍžh×—§%¸™²ûE}…-5þÊp—Øj@“Ã* µ&—&éÍêLEŒ¨‰¶Ï“„æÃÏÏä'&S+/h?Ѿå0~’O?$îɾœ-hÕ XZ‰Ç›J’˜•xUû©|• ÙABÕošêéO/GiEÞ@Ûv»ù+üIÞ7°A¦Ì'mjïæD¥[4ÉFþ­Ã;>¡(³ 6)¸k>Çá›ÆuÊw™Åm__-Š0RyÅŽ®úTÄCŠ¤]l˨ºÑ“><úãøb ¤â[„%/½ˆîd¼h4Fò÷hÚñ‡5q½- !Ê“:Ëò:Œç¥–IØ0(Ûç`x[q;±}Í=žÈ)–«™GGÒ*†Ö £PíZPÜÍëß<ãÒÖ ã ¸c7ùÉòãV2™t‰úéç¢@‚QY»T¼ ÍHé [Dž¬Ž=µ½í[×”6D+þTøóÙ}ßKº¶3):S|µÙ»DwñIÐJ3WY¨È!¹S~M¡ºÕ!þÙ\Œ]Àwüùo«±sÖ  IbVãh•áƒÔ{?ñwÆÄ9cÏØiÀ»3õ/iùùÂÏH¾dZË×N¬žÜ$«§<ú¨¢–ÿ endstream endobj 3742 0 obj << /Length1 1465 /Length2 6609 /Length3 0 /Length 7611 /Filter /FlateDecode >> stream xÚtT”_÷.Ý(¤ƒÂ0À"!Ý´à0 0Ä Cw7Ò!%RJ—„ ­tÒ)Ý‚ ÿ1¾ÿ÷ý¾{׺w½k½ï{žg?g?ûp°iëñÉX!-aŠHšÄ/ ÓÐ3ñ ’ppèÃÑ°¿0 ‡ åG"ÄÿÃAƒ 1˜<ñÓ@"ª®$" <ø—#%‡¸Á­üU$æBÂ!‡tòDÁmlјmþõ à‚r@ˆÞÿq„¡àP AÛÂ1;B!=$C{þ#—„-í$º»»óC]ø‘()îûw8Ú  s¡Ü`V€_„šGØfü$}[¸Ë\iv‡ ` à‡Â.˜W„ ÀlÐSQh9ÁœÕÿ8Üü=ˆô¿éþFÿJGü†@¡HG'ÂŽ°XÃ`-Eu~´ú>‚°úåqpAbâ!n¸Äãð»r@QFÁüKÏŠ‚;¡]ø]à¿(¥Áœ²ÂJéèC ]H~Õ'GÁ ˜c÷þé¬=éŽðþ»°†#¬¬‘°ru>FÀ]a*ò]0É¿1x "",€9`P[à¯ôúžN°ßFÐ/ÃÀ×Û é°Æ€ù­a˜‰· Ä @£\a¾ÞÿiøçŠXÁ¡h€%ÌŽ ùwv ³þ³Æ4÷˜ `´üzþ÷ï F^VH„ƒç¿Ý÷¨®¬ ©®Ëû‡ñÿÚde‘o>À÷ €1/Q1A€ï?ÓhCàËøw¬  xð§ZÌ1ý«b·¿àú;Ü€æÒDbT pý[äf`(æúÿ–úïÿ›Âeù‰ü¿ Rtupømæúmÿ?ÌG¸ƒç_Œh]јÐ@bÆñß®†°?C«³‚»:þ·U Á ‚ Â#f>0¿€ðî¢÷€YiÃÑPÛ?’ùƒ?þ5jpLéÿu·`¢þˆ™/¨=æþpÁèò· †Ÿî«€€"­~Í™ XA¡ ž$9 ‚Áof ­`¿• ò#hLÃÑ`D‘üj«qÁp†»Øcº`ûËø@KÔÞÅâò°€ FA 0˜5ú?`¡¿ðŸžÿ Çäp„#\]~ÿ¨êŠBaæ÷·¼0¤þµþ}YÀ`0(Éô$ú0Ä®&¤å[• “;ß—A‚ÅåÖÈxãî0šsê…·­:ás¥1gÙ§Vå·úÓ´?¿ôaâÙÿ6äaö>+p!U9¥Ð½*{È—÷áâë{«’ÑfX4-r•ò A‡åæSS<Ó{I†“?BE;„6*Ö ~¶ºl˜<Ø8ŠÎ(ØR™Ð±29­;8ÑÆlìËèÆfqT(ÓtW}•ÇÃ?q¢áqç²-1 ž«¦qççû²zºÓ„Ž_ªuVŠ”‡Q3Ðx©²åô'ö2Ð&d©6¸`qÊ‚Ïä^§Äßa(t ã\Àu¬™13³Çu18Š™íúeà؉(­›ªÃuÍ-£‚œ}l?¼< ^pHÞhAé§hAp }¢ðr.è–gñÇ„ÖõÖ£H¥º/‹S)nC;cöì(½ÞÃ[ý{\r¹ FÑ·Ê74µ.£–6ÞgÄ;5K‡žÜÖ©ËšÌèͪ×ùèˆÌÃb >Ù~]7“cxFEuKîŽÃ‘ÑúÔs¥£ ìÀIYe2!óŽa&~å=,… Óe ‹KeãˆþN‘×¼Pêe˧œEËz…Ê6ÿlüƒ~säœðZÝÖÐÇd1JUzKsfWæÀ¹¯#ÇŠLŒ/Õ³ü@°‡‚LзR¢üë{²–­º18ÕÞ _J°kHõhºøëÐãùS}œÆº73E(J0Þ­ßÊšŽgn.¶ózçå¼4ÊzŸN… ¥°¾?h&ŸÎk»ÒcùŠÛ2ﻦò3*ú$ºTbiJ9žÂhŠy¬“¯à8u“)÷¯îmW¹¦g^Ksíä{RQ'4Ö.Ž_ÙvC³]ºçP÷õä.œ´ã=ƒU²&ý¬=qQKª-«L…§7¹•?Ô~;u†¤0¥K·ãv<œ"¾_d׈Só²œM,2ƒ²£á—JJíÇþGVtìgN]y‹TÕG4~éaE¿‘›ädsöš'JÔÐÅJyÔ»²LP×zõÒöþbyhÆ°gBÇMË—MîËßF,¡‚þ$2è#pþ—5gÇ»Zâªvó‰Ùá]ÐS“‘!ÿú™vaåm·|"¾CS.†MˆhïØ–ª>;[Ý,háa³ 3¥þÉgÁ‚XTºû.”·ØuÏñ"îÖDP÷'â C’¼Z$ ÀRM»íõ¬õGV­¹„§2Lx‚^ãýdïçD^Ì…xøjÎU÷æìÌ ¤BÝL7ÌÃŽBùïà\\AñÜ ì w3®3'>‡P² ]¾;-ö‰¥NóX:]|GvÝUBRBùš«(6=òº§;0‹q²ýüÜ„ÁÚËëX:Jí#)Í4Ã%{„ñE½*å|üq€¢-ù /f}èxŸÿ+Èú¨íümyv¢*,å¸û=áÆ7Ò?)|åœþd!}&’i©)E+ƒ%«¢ þ0oÓ· Xç% o%@kTge¡èYIDAR~z­2X¸kFx“—ë]59æWúñ³dœä}s({®Kª-ª:ÌÐæÊ%ïÝzüÖ?¾éÏ Q"g5`WIìCÒC¼J®>š01!ql `HWF‡ñ휋ŸïÄkèñjw䧊hñ»øú4es¶ç2ÊŽŠp'#ÑÏoŠ2ŒÛcìÁ}A¨U_²[yn9öÂÜg.m=ºÅ‘ÌV_û¶h|ïP¾€îvƒôÄÊzðùÈž‘0Âï×.\B:Qþk„ FÖ¢ˆ™%¥ áÛƒN4ƒ¨hÖ€¢Fl:Ê1{±ÁÔWâ|Uô'ùLs¬<ú‚¨ŸAKnn³ úEՇؘJ߀…YôgŸåoF~ØË=ÛÀGŸ3]¯ö–ìÌ…nuµ ì²M=Q¸'±Åš²ÝáHÄɽ§ÚJ1¨çN'Ì&4T·»W¶<ø–¹t)§vo`¸64,Í i[5õ‹óýà¸Çå&!󦙪ŸÞé¨1Çä𨧉U®„ÖŽç3<ˆ­Jí£ý~53kCèÓW¥XýTù‹ýA õ³TÁôì±Ìæ©ØžðÃò»Q·X³?lyXv? 6|D\ú!ôΙ§ëYƒœ»}7‚ÇW‡Ú³g÷QUÁ ñ% ïÉ%/ÇÓVØs¹™ÍI$uwý¹Æ€‘H¹Âe‚ò ˜h‹SÊûŸÙtÀõ6‘±:B÷™¶É+½E•˜Q™R¼feÚîpoÏû£k5ÏoÍÝت^ќȜ9þêõØæ‹ ôÍC¬ñ¸ýy:êr—\¼¶Hgæì$ÈÝ•ï8ÅT/{üU =. ̹ý.Ë$›àÕ¼p)–^Æ—;eÔzÇEJýVLù'Aïy#¦Zn$7Z1òÇ  25 nÉÎØêx´â<=]ßÃ2bØÅ}c©ÙF^zœº²?YÀ‹¹W›|&s+Í…“=F„ >0뤭j“94  _ŽWÜã🱺½™Y[¦È6ühñ€‘Ð×÷U”³ÝÍA¦”2OË‚0ˆáüÒË¥Uí¬GXÉ­MÕÌÜ@—ÅëU{9\9ð3}%ÕÍçkÀ¾)Ô îY0cSôiÜ(ÿ÷Ý8­ðüä0JiÝ4zæ`õ«ŸáÑÇ 2Fl!+‰NŠŠpù|8=ÚÌ"¬ªðÚ/¸ ø:7*a (nÿFnÑsAW.áàL‹&XJþDý›}¿ësMÑPÂW’DºÀO‹F ÜìØ›*ŸÒVøH‘ô&‰ö~Ù ä âße(¨á­ s°qîæŽV¦†¦Y‹åN:\nYÿÐÐÍäÛº/ðZñÃB›…uÏøLÉ}tÇu¿“À‚'öÚrµÖ¿Â½\RÆØYê§ÙCÙüéxržam— ñómâ÷© ­¥žöñ/Œžãõ¤E±´Ôp{§9[ºZ] 3¯ mDhÆè–»C¹‡¤DFØvŒÈמø|t<#Ä·,ó™ JÞŒß,+íp Na,}t2yk]&©ÐrÛÉà6xŽC®Úðy[çÈ# ý׈ˆº¯<Îd‚ÂÍ꜉¾`ƒÀOvP@æ%|lVÚó“‰ÔûkuÅžñ®ç-‰ÛÏ 'äå ¿„ßh†:`ûDhzç¨Oî²FÛ±òÕvNº·Imh=½s¯;âŽÓ…d.i,õêZ“§Û‹ñLfÐŒoÿà1U=ÿÚ[®”r"é–)5MË·ÚoAαñÃÞ2T’·-¥‘²°Õ<‰:M¯þ€7Ùo;w’cÄ .ßü3àkôQÿY¦÷8Š}=öøfùlt80Bºr“QÕ8 !S€+MôŒìÉIX³Œ§,zËNÀìõ2úè%nßÄwv«šœNDÊÚ ²&¨Î yÇ|Cnß°&ûXäóËç’t(4úCÇö”À©…:AäMáll Þ+pým&A\ŸÙÔ¸f¦’ú'*tFËA³¥Ÿ¢É²xˆ“»-ðt#ó9pê4ÁVÂEvÇ-v[‹¬SpËÂQ¦ NzÊ ¹Þ¡Qb—ÊÒ€®‚öóòM:`·'Ì)x"‚w`2Ž0iX :]r±'(¢ÅöÕ€'#fÉ,œ°zêr½Ž‰ém·˜_ui’•ç$Q/’wÚOȥϳ–©^3Wo‘’mªÛ0/ijýÔØ6¬mÉf ^±aíç•Hôí’^µó)"z¸’¥åu›¹½Î<Ù¶»g¥=:£0aPès3»HºX”¢Ÿ´­ØÙ¥÷É©«ígŽ1á„Ÿ€6BVÙùõð‚eø{»Æq1Óî˨ëúAQ²ú(›}ï1pŒ“ß3{´ͬûDõ± V©ñ1Cá¦õ­D#†7o4N¿$(h`—Pƽª% _ˆÑžÅO* ŠVƶ|xÌòéð´òí8õÞ¸CFãênçâN制žmÇrz~MbÀ-ºÙ™O1Ìl’ÿðKíL}Àê·áOx¬-/Œ,~RÔ¨ŒÖj9=/·çA^‘‡Éîpô|~ðê{þ“m¶ÚÏ3n?ý_äPâUªE 3h;ZŽáŒÐqÌu{p³»Ô¥­87)'—ŸâFç= ¶Kv½õÁ{ÿ|wÑ{v“/ÜžWY‹â¿jñ§á`ÑuÔ±Ö€¸’ ÝgŒT…sþüÂáFaü1.ûV|Ù¯—Qæ Hݱ³½…S _5³œ¿à5×[SÛ{Ö<gw·A‡%䇚À)¦cÛ"#» [÷$F}ú•†sZ–ìŒæ½_a8Ê/ÚÓq6±!¡Ÿ9<¾3Ìfò¹Ï¾3DŠN’‰ð…ÊjÕu>]íG l®m‘‡õ{Üg;'ÝðžÀ’òßüüÉîõÝ"4½-¾â¡áBTYÖUx­Ä7Ú~2ânquIWº}yâu•ÅSÖ”êÀ[r·{²Ö¼fzÛ6K'E‡ýcf:ÜVuMŸ6Õ±Æü8ŸéæŽåm÷¹|öÁ˜Š&ªar‰óÆû¹’øèåäE÷ÁŸnM{¡;½í”Ì •£KD¹ l|ã5Ʀ'è øj*y¾]X9Ó U›nGuš“GLEP¬µ`§=éé»Ègïé'Vë$Œ_!€æ3LOë™åC^ïðöu¨x„_~^MJŒláÒ:XdÇ“ 3RÖß0Î,¹ÃÉÏÌbì}æŒ ³{W9*7sÅÙƸr£8ô­:rG¥Œ©E^#ëÈ ánÆ×H‚½p WôŠW{¿d@O¾ALŸ8£Õµ‚cbÒ€˜‰¶3*$Åù)XÎ958艶È)Dð+ѨØÖèüç7‹X¹±è¼,2Co}/õê]­øÏDuJø6Lå ã¼âµ‡“ÎiÊýz¸†æ«£+è‹ç4ÇýL6†µ«Ôj‰¬WGï^^o?î*×B±l~á‹âûvðM’íáxhˆ«+-ª­CÜòEøgÆ]ühb ‘ ‚wÓ¬^X¡·‚k'Ìñ¸¤ß¯¼ÑdP…S»‡ü¨Œ¾Ñ[?]\³ÆÏ&:ž¢xUA²Ké·žpz/—Æg©!E|‡úÀ¬ È@›øæX90Œ–gú"o5î ÌxmÙ#Ù,b´IùÑÈÛŒrõGÞê0/| ;ts!c¥cGI*Œe¿p~Yv¿íòbšvš…Ì"™zn/÷@D££|¤.ôý!( Â‹¿£ã2úé©ÜeîU‡†½µÎŠ&K_uN©‚ |ߘƒ@`sì–Ú@Ë*H܇ϸ£»ZÊâÑ æ1vªyï£ÈÚDíGÝRà ‚vhä%'/Šo“cŸw¨ô—øt…tQ4|˜ ‘íò¹8 û½»0™"‰¼ó¤¨2 ¶­:·ÑÄKŸ½Ã äo’§1öµp¦VTFø½~’v–SUVŽÆÐëǺíU©]„Ö»„³¼Í) ­1 /)m½<ÍîC¥Aýž7ݧ¬ïâ× …q/“ùê#Ò+rØÕV{µý±[“psÄn 8>á‹‚ãrÓÃÂõcÅ™MÆ/3]M}nàÙ™µÎI”'~ÏŽ0­ÁÇÊØ}Dî~ÌÝ%ÖxˆÌj›£ žiãâÞS涑Ü|ï½ømôMnÓi?}ÿú2®Ó«£i£ª{uQOõ/ÛV–?¦½Ê¿ÓIÜ'óˆ" Ç®·±Ì·ú¸ ¥“ƒd'ζÖ~™¯là™fBCC¹…ï2IèJ©»Üåûóàbš‹šÿ–a»H:5n±9a¨­ô‰ )'ýd[O:ë=ÓTqªzãk ßçÚݧIÕò?Ê8q2ž:2ó~|½ÑU½Âh§Å§ .»ÀÇ6¨VTj]Í~—Ò¶{UœÅã¯6û½+?ܬ×~¿jï”|™Å¡À¨Vºêƒºzfú„b0}ÿ»gxY4Û äeŸQº<ëôÝ‘)ê¹³n`“…pýt·î©w~Ûí!ªy:~ú`ßE’)>Ù¼! ׫Éß{à3?Yý;ý>7Ihˆ¾ ˜ësHîØ›–rYÃrðÍñ}×%4Àí‰ x¦_"&ÜL[¶æ'Ô­/Bñª¸ø¦ÃYÖø Ad}[.o%I…s 'egƒ…Mæ`÷ûÑ-íð:â+f&"²\VYƒ²¬÷–ìén\&ÀE_ïYÅh2Q²k])&³žuuÍ[á)TR)W¶ƒÿ}µã žûg@ÛÚZm»õVﵧŒÁ¤mòr'îÔ¶ô'À*'!˜2P%K¦ä7ü°Ãþî÷ÆǤOpŸ–s"or Ø ½“"€L8´Ä৳î~•Œ RÃ{G²ÜzT/3âS‹£Ä» /½•­»~8L.¤5y$³*ÛèÐ1ê½îâp‡zèt. X²ÿ8Æh‘[壺Ž× Ó,SÔÉ øÄ€I’¼ŸzËoí’ÜjÀ žSÛå©É£YâÔ(grÄ k7-Ì{‚#Ú  Üï#(e†%—S  I «(3a´‚Ô­Š`³Ø|­>¹õçɯáê¤çrIwGmŸ“¸Ë~%ºÙ]j•þìó­Î;«Oÿ 8O9/غ׺“-­]¼á‹ É™åçë.ûòÄ¡¦§íÃq¹XÞµðs,Zš+‰!Uœ>¥âÑ®G^DmG-Cýe‡§æHhΣ• d¥Éq]]ÝâŽ'jëý¦Ílz9¿£Ìrœýw1•`NY¡Î;±ÙlV]Æè/_ûä­äŒÆ2Iê»·•½_Óì/ 毆ûŸZGTsh«êP–Í3'=cë5™ÅŽ¼ g`ìöš“±`<¤»źù‘ÄRænžÕÄFµÙš¹TT¼³%Aïd‚¨L‡këêoo+fŸŠ=í{$ÁJ¢Œ ˆ("ðl0–²æO=ì¥HÞ«‹L¥Ö¶°@rW¥]µ–”…dþ«î¬ö¬u#|zÞz&:¬ì ŽXJÅ®I]ЉW ј|Ÿ8ýŠMMô±w•ñ±¯PÐ5•Ôå¾ÈÁüiZÚ¡Ží©Yñçîë¤"ÖlÓâæ®0†ÈÍ\~ss¨/-3¿Kqi!Ë’ùd–’ÔµôyõÕ~¿¡êÀê©ì„t4u /Æ›çxÑãA;æµÿÊ­=•¾zhý¥pŸçl)Z¸t|íñt¿Í^øÙÎtÎ7g5‹•ìö ¾¥òYûFï õ€ü‡|;]¸E¯­g²©¿œq:Pš7â{=Ó[~ GD¶Óu¾Ï`¯Éœ\Pó†×?`?êvNlŒ¹” ØÚï…™Þ„ÍÈ•¢Á9½¯¡^çc¬òä1zêI‡;i±oyæiÛ È§UcáVh4牗MªŽý¤€IÍ£¦µV²¿ ѽÞiʼuuäÊê÷HÚÂï.‚‰¦¡ÿÙü2]^X Xpƒ¬ºÙý:KÂné"x¢%3&+»ä˜æ¢¥™:ÇIKa.ovÓ—rº{Zê)mB7Z½öDtR—]p?\¦¦žCpÞ¼Ñö&âe{R\HOa5è÷˜ùN¥èp¤Ô¥ÐÏŸ-”tÔb¨KãÝê:Ròö|fï{7¦°ÍN@¾¡&^’™p3;®ZêNã”H?%8{èM!C^óÙ8»ÆÁ'EèÝiŠÆSí nÈ‹êˆwûžw‹ê­l<@éà ’$³®mË\KÕåƒZ6žÅîAƒG”šFÌÇoß«l ‹¹6ÒñÇÀrÅ®w×eK9 ^…Æ $þåg,«¾J&G?õ¿¥„ùþh8ÁÇ endstream endobj 3744 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 3746 0 obj << /Length1 1718 /Length2 8391 /Length3 0 /Length 9519 /Filter /FlateDecode >> stream xÚµT|6JKH# E%Fww7H 6`06ØF‡ ‚t§HwwHKˆt©(ÝÝ¡ ßÔç}ž÷yÿÿs¾ïì¶ßu÷}_÷ ;‹Ž>—,a QBÀÑ\¼Ü@1€¼¦¾‰(äçùÙÙ  hä/˜Ý‚DAp±ÿRGB@h ¦Bcô4p€š+ ÀËàã|@ èH1€È hrÔpŠ]á쉄ÚÙ£1aþóÀaóÀ+**ÌùÛ ëABm@p€&mqÂD´Áú(íù/öh´³»»;7È Å@ÚI=ä¸CÑö= ‚tƒ€¿ hœ *ã&dØCQp}„-Ú„„0 j£0®p0 Àè«j´!ð?Ê8õÀËÍû·»¿¬9‚ƒllNÎ ¸'n°… m% n´š‚ƒ)‚`(Æä‚Â@Ö…ß™ƒJ²º¦À¿ÊCÙ ¡Îh7 ûU"Ï/7˜.+ÂÁò''"ü•Ÿ ±Á´Ý“çÏdáw¸÷_[(lû«°«3!êâ QUøKþƒÙAÐA ¨ q@ÿzŠ¡‡yþ£þ{¾A!‰y1tâxób ñøÍd7Ƙ05úlHÂ_cæð¨ü‚~¿øù<÷?£ûÆ (Lc (G̨ìÿÆyBkò¿áßØö_&„5dAlÑÿóÿÿ;¯ ÆÌ ò„AÀPþWtLKx0>¿1>^ݯ AB\\AÿdÁ‡Q†aùo:AᮨÔ0€+ uÆ´÷ï88Äî÷? „ú¯ú<Θô`Ìüü„ã ÿ¦õ/ð_C³qE"1¿w 3Ñÿ¼_JÄbC8ý a#þ¡æEëE•,ƒ;×êðÍùÅöГÞAôý©,o{[¯”'\ä¬Àå´ƒÉ:Ÿ‹ƒÇ?ù0<Ú»ñ0û:`.I%¥Ø»,wÀ•ÝyüÖÂFÐÛ '‡.“ïÇêÞ½me†kö ÞøÓUpÿzÅZÞu;jÝTtà(8#cIb@GÊf´oã„›°°-¢LÌÉ¢(f)®ª†£×8áШs¹ÖºKÏe³¨Ô¯_ß¿~כ̔£Þ])TLIwÇK%c0®Ž*öµZ# 뾜à™|qbÌ=º|§àûs7¬„ç¾Oæ¼k‰íãw­·Ó’ Òöjp­……¥ qû"d²h9˜otMÖ>PN(Ir ê9¢j4ÜŽQâªüÙ/¿0`î/†¼º½gœBÇ~8È–ª‘ù37RÛÿs—wèé‚-îÄYæRí<è¢Ü]¬Õîtñr_Kà &®-« lêY˜ÊÝÆ0a‚77â’îŠ4:|.<ÞûÎÕ}çK­RÔ¶ÜJc,ÇáV ½—·¨Ub‰á½›Zx\U¼$ÔÑ£O çF&<'-ȱ+ûzÉ©æ§5FWd KÏjZ˜µ‡dÉŽöøR}mé³açuH÷dòyÆ8܈]UuT¦<_LþP•C“&”w²7ÛÍ»å âÒW!¾,)›ìØíÓ~V×Ûf;âºý&q(;^‘D¤á\ä±SÓd’é¨lòŽ7õZ7Æʽ_,Nè¡yùû$æçEžÜm…™¾Qdzu¹ªìÙÛqĈEÝÑ°’•Û𠪕éléu~z/‘5³VŸ%m,e¿Èªë~j8—4½û•Ý€Çáâ¼:㱇kÀÀ!cF"íöØCøTQÒü!ëÔãê´á× éâëò6Š+Ri&Göú­û•1_îDõK9ž´ëøPïVMM¼4û\¾Û9JOá “8¬Ò:%Š¾Sò¥¼Â$× Ú\·Ä% þiß0š¯½†eƤbîk¡<±-ãëÍÎc…Oq³, Æøt%-˜…Kkš¦ ½jèìCcë#ZmΉ‚›©æÊß’Yµ&³9wZMd=óýuéšçî`pöD“ü†µÑréϬlóD¼¢òËWEÎNµŽz u¢”"uç Hÿ€“ÌåÀUxÖòRÈUÀ9>n|KgüÖQ·ÅHÁÓÅûS (îÕlÕ´míhù7 iZµüxêf‹²æ}˜Û¨Ð‡Òi5ê@ÙBæc™âðFýkfMÞ…´b?ÙU›øÉ ÝÌl0 Š]-â ™‚R0¾fR˜´Î:’u0g?)ÖÄÜD[Äo3>]eTHJbVA>ÅöîéöÅÔ߇üú¶ÖΞš?§—߇_%Lpä*ó­4Õ<‚ã–ÐeDÅ« vGжÏP–\c½ºU`*žØ4Õ½î~n±Å:«kðM@΄.·2 <Ý°Zd…Û(XÃBÓÀשéõÎ}<‰pºÌ– È¿ûó³¶fMŸ2tXôçÕ¥\UÉãN&æÿz±)»A´Mæ4ôVrMì ö:œ;¬7 ‰øX§&(+X$=3úÒÅl.99)SÚ#Ÿ6ùe"”ªa¦d.e}\p¯"ÑJwªWR8ý< Ó,¹>ÏÉs§7µ"Û¬½ºÔÁZ,?Ò4 Å_|}Êx9ž™èHÇiÂÇ^O "˜\³¿lF°ío 3ßÌ Y^uY«NÍ Ï?M0?8ÃÒ” ÷—ôÖml£n—å w‡‹„äÅ<ŠÐÞE9e,.¬TxÑd>óGxy­úSªŽ+5Y놊´Ÿ6ÔèO˜ ¼J¹(V…ø¬ÓÍè¤ß•€;C û{“A‹¼Ä?)“;ƒåæŠè¹ÌÛ„r2oÛYÖ§7+R|%®¬>iNÍ}oâ©f“ÑY’Ž÷AºRöÝ­‹ßäSo—ð(M"sýæOcz?…àñž˳ÞY¹æÝ?„>ØQµ³¾… K$Í*-sú^ékÄvyÐçA–ANu‰#U4bþ°œmÞ^s›àÀº¥%y$²"õ:,É&©»Ú#×i#5nð”ÚCÇ-[–Ñd»¡Bž Ò— DåöOiÔ: ÜîReZ)ƒ˜u¶¦²*‘óëïáî 4~³@ Gµú»P/ÞÓù ð”þ1ÒÙ,Z v ŠÔ´N- Ÿ:å&¼¯Ö£44¬CO\†Ùõ‹5ëë2> &QÑr&b {õÞAlE ˜gpû2ùâèˆ|Ä÷UsØqÉ…‰'G0š(ßl¼uØ“«ä†½{¾ë(žûëYV¯œ!è‘Bs©söÓÒÑNJ£¬dÃ…Ç­"¥4اŽ€ÃYŽË&‰.=~_/…z1KׄªõØå°»—l®Í'“Õ~‡dÌ~i\?™Ö¼¶<2lá!DëØ{Hhê {*¿ï—˜²7&ä.ÐåiÌ÷m¹ÞŸde oÉH‡êü¨Îv‚d‚€cyyØ»×1 +º0{·+”—¡WV¢îËÁzC”¿ä…ºÈh¹®3+unY@ ‰Ç>€SÑ– Þ V•#”¯¬j,âwìì1\ázð|õ¿­9sЯpÄæÌ-pÑ3„“YD<öÄÐé­Z‡í+£åãö€gùNâ­b<š6g¡ÓòÛ%AÄGê¾øR°þEËT3ÇŸqµôË.+k/Õƒ—7˜mɨØ„/½™mÓ À*÷æž8Hù ¦EMU“=µ©MÚÿ?û ³j¬Ïc}€@ròŸnò<çÒ¥·ª[jÙ]Œ,»0Ò9á¯v+ S6š„Ýy—õ6>áÛéKË'™ÏéÇXÝéh·ÄQwéF&nD+?ï]öŒ{?ð‚æ)‚ÿý¥!%hã™àczµÂ½¾èGyDŸ/YÛ$ãUéß·ÅÕÓ8/d9MÚdÄ*îV®QâK!!o¿ºàuvÂ’zØ­öI3 2ÝsÓJÝ‚vi…é»Néè8¿Ì›½ÒËå?M]ˆÀ `»t½6ø¾´Ò¤câ¸êöðêE6z@fd³ÔÅÂè¬mà #÷ ˆFYy«L" ‰}Bä“#Ûhi¾ÒkQ®˜ÞŒ]/Q.wÇc^ɳsh§ªpÞ$W´ëgËV­¹@l—y"`¶ú”¡îÜ—9ÆØÙ¦4`*S*–£zm¿›&›µ””³Ìù—Wm$å·SÄ5›í#*û®y'38ç+P½RKQÅÁ5*dsœÙšÄ&"'ì.?ï¡à £iU"+Ù ^4Ga´9O˜¿Í-JO;T#ÍÎò -&;¨„ŽGÒûíM>Æj2ÆËŒYÓ9¥ù9dÊQò·ó¨pâ{ ™•Yú¥Üˆ$6ɽ­ßÕݳê×X'Õåȹds¸}Ö¯Áãq¤Wõ,0ÏJë…Ÿ_8++¿›î¹ís¬kí±Š©ØG§We£I#ž]ø†-Rh&NþfÄœv}Ì@ ’_ÐõŸØfźfI̯ǥ õ§&Pd# 4š¦ªÿ–ÿ¡ô¤Ú»Ìý–À»?lN“ï\u79’/OPRã îý|ÖâíV4ñ?D*>¹»â›¥rz™î *ËoÍÝð¤ Ë* ûÎù„3*ÉâkÛ ¥m!ÍûŠ¯·?¡_ÝcG;{ƒŠC¦HÌ’ó*ÏÞÕ°^hŸ¹±ãÏtþkä9KØ!-c³VÃ}ðdézkJæýg‡8y2ÇÍÉj“ç¾,Ù‹¥ccc°Ú‘ï y®´‚BÕáHÊñ›‰—¾ «~lúB9v×ÑøÎS…Óäc*«ßN£ð¨áß\›LÎE† ÄÄÝ\=$Þ«•nã8Ï·3œoô凵º WÕÛóèÆ&ÍKßè–ÕT¤~Á¥Ñ,šØép‰‘ɧ [é›Üž+y¢$q­îÅ] Ígg:›5P6›Vl¬•½<>0Ã)÷SE>1:©ÐïHqÑ‹V¹¤)I5G5 =9!Då”gäbãïIpl¦ÅÇ…úmZ¿) õˆXÂN¼òÉ£ c]¾5SÖÚ¹~•šÖ8&ºé þÎ0µÁ·ø>ï‹sö÷·CBÒu?vpEŸTÒ2ï,£Â–óDŒçÔ$Æѧkk+ÐâwýÇ£_•ˆí»ÆØ&"ã,³¹?;FàØå%Èö`óSÊ\ÌFî&Í‚§®,Óç—äêIbB—Ogñ.eío„èê‹?–bzÿ€ìVÅ»aàMMW¡gSÞŒ )\Æ~‚¼|WÊ‘kìû¥§;Þbb1ƹ™uö]bâÛ“WkËjSç­ oQ!(ª/£è+ôm¶Ð#Â?øOö¥—í‘·ÇoüÀ²Ñc>ø‰GI½Eµï]{¶HK}ÿÌßFmʈWI³šoU%éªúñ …/nP«4Žptj–½óÒgúaÖ/©~¢Ï”×®-Ouf Ë2:O5œÕ ©2¿&êSŽ¢šÔ¾ç-øÔKú»aNŒµÕÏkŽO*QwB\·|¯‚Ò¢3Šµ«öÂcÈߊ)ó¯<Ö›EÊ`?uu¼µåÛ§¤¶cÓ'ñ6³Ÿ!ÿøÆÑ«“ÿ¹è÷\hÄL^é7©3Ùø Úò‹Pâ ØÛ½Eí­ÜPdžT[Ë¡²qãíæy±’5WÓÍ'Di.Áo³¤×-c†w'Ù¾zŽe+ç Ɉ*,Çܬr!ëGç1äêÞæòÚÍfÇéSQ‡ìÞ­ÉÍ‹Ë:)U²Ó7q¹„/ã_€tÌâo}ûAi ì 6ŒÔ÷pߟ¤RÑÌ~”çrÜìf–Z>;* QÕå*Üx=qiƒ:]ƒåòÆÔ-±Ç_q$¶hµRhYMµÊ¿18x÷°~=ص¡ÜÃï“‚‹ú{ªÆnË¡_RŠâË]í¸> ¡op=ð\ à“5"ê2!¿I Ü$¡þ);ƒïkÚp8–ò†ùb°1-yÔ \Öøg>uñú#D9Σðq’lÒõ& Ðô·§•ýÛ£^úkÔe|aoóURvݶ¹w<®Ç‚27?Æ@ôË­ ¥ÎJSí>ûB쓵Œ˜æðuEóˆ*k/a§‡°sOy^¼öf2"˜ÎU)‡¬ÅÒ¢{쾌~× Ù–Ï(nÍ¡9¹Omˆ ê½5ÙÈ[{#¥•²^ 7Ónb`Dšûšvoü©ÃÂC>;éÍ­fäþÔ\_¨ˆaôýôÆ.^Žñ1¸-D=ê ¼M¢!·8UIE¯¦8ÓsIÑ{GÛnwÎý,Œk\7CGzLvˆv" wß2ĉ>¢cÛê|—•[yó‚—]©æ«×ÛîmZ’otwÞŒ×)–tÍ ’ìÊòTnD¸[ÛÔâ¸P"‹`â¢Wœë8†6ç4Q"Yü×ÊÏl¯#KÒŽœ£KéØSÈ–[ÌH –†*jÁoÙßÕ9ÞZ¯Š 8}V~‘hyÆ¡Á@c3‹÷éç‹·oµiƈü7X4¸öL¡ ZOœ{Ìf?^’œèž×P¦âœ¦eéù”Öäø °\Àä:uË¡4T"ó»©ß?j(Ì7Å6Cx÷å3ÛÇ}tŽn;³÷õh‹û®C™µ&3yí6§{Z¿ÓѺȦVߺN”®³~W£Mºáðâ®ú=胟fVxƒvBRÂ-ÌâÌ$ÐÄ.HØÁu«Ž¼AOÌ$¥»ŽK=ûQÞ±£ñ¯Úk”¨ô×Hº0Ϲ/E_ÆPµáëüO³1-•Ö7¿ÑÞ³YôTῺ츽¬Põ)ñöÖ]2#Ïän,¿»ŽŒÚtßSzy_$Y¨úµ ãIÙ>È •×“ö@©GQ"4`ÖØllëÑÝäþ¥x*a±³uÒÜbK•j`(Ÿ}8DšÈõñN² <.‡‡ô$ÿAù†9Ò¥¿„Z[Pí Ìp ÍgÃõá~ ÷m[M¼Ÿ’±Ùîß9"sµ{ùzvùÖ H ¥ɶ‰UUòäç[Äßß‹t|~7Ú ®¼_Èe.^ºP ÞÎß"úXÖ¤ dªßÝ=¼Û0…Š`› ÜÔå)”êXqœ¹_x6CIW»‚Šê>Oß#šÌnÊaˆ(ÇYm—ÓíŒN Š¯ju¨ôZ»Ã'anaåæ]ùõíŽÆQ/°OÛwœý· Ë ²¦üŠI†ýƒÃ¶wÅÉ}ÕÃ7ï×-P”°<;¡hÅJœÂ™ íŽTÚW¯:-€ù¦ÓZmiª§Š’týÇ1’qz„„×OÑ·ÎY`=ëÉÎò~?¯+ž•³õ÷Çù€ÏMÒ íò©}¿? %p$K¢‰ß8)YãÊvÝ=8ñîDzà³íúö_‘‘nÅÜ‚ÄÆT¹œï¶2ç³Ñ„Ïj:>oÌ¡1|°–]”ûèŠõÆJ@EŽ Õ´DÄjÄY‚My„œÓ»cÇÙÌ!élÿç7ϳÖj—Äû¨¿ÇŠ°ô¾Ææpœº¡$G&CbåøÍøñü¬€®Àù¬;ô݈|7G@À¬ló³}oÃÓª1‰“}\šm?œ¹ÚXøÖÊO'nƲA±Ž"aJ^í›p†ò2 ú‘Ñ|Ü£b\ŸtÀÞ9aînz[ Q+wŠèA¾°u5;DÍ@{_‹þ©Ãݼ>½aBÇ;‹#( ק_ b\É;øB  c¥„- qà¯.‘ltV¤úÒ$·vŽ÷9D%⥪•á÷§H WÍú·Òf8¤—£§(Üq¯>ÖÚÝ{Öb¡,pÞØ5wv¿¼øGÂýôÇŠIwé—Øt,3MzGØÒ…‚e+^ÁQ{ßÕ3 š?û熟Kð-’f¶‚DU—üš]á·2lEù¶îìž=|÷`uÑÿ‘—[aGÜ×&åà,å`“.â´ì•GÍD(H,,Eú8F9>Ú‘2”açŸhZõûZÂD`í¼yBr?ppPPŠ#+ÀÃèjÊ+«ØõÚ¾û>ž` y¾ßÓ¯òTJ’¶ãÐKñe%i1”$O‡ÇeêRšåƒ%§µlå¾âÎÝsÖmÚŸz¬b™xnp’c.ãàçl½†_MÐ×'“mö2T<•µT« "°ím>…ÚµŒ!f‰UyËJ^B‹ú¤®x×ýø¹úÌŠÚl *åw=0¶Ÿ‚”Ûý.‡Õäu?¥É„3Û‡hÎr&©½?ÿ¾_¢ hT…ãmã£?µª=¼ü¼¬‰OÔ}çèV“•¸™ç2QZB=ú„ãN¼>»?e¹}YAZˆÈpHéoc«Ua+gO¸CdCõäšÛŠ^–W7³*§Ao?‹'™ùKÈîs…Ýpº¢‘,væÂñŒ„Âg…c<\¥®6Ö> L$Õ7¾¹©;ÿ†Å#~ ‰KÉ|?Ò;ÂÆëE@ª–ßë·›QÇ.v¤¶yO[ö½8%ñwpÒaë¾xÀác¥L\å-:ü²m-éµl+äÚµì£MmÓ0Aÿ³î0½Þ‚¾Ï¬F?ˆJqX§8ü]àqO™Ž3I7…Çïl½¢ìQ˜z×÷37cªV´*5~i¿.•zØÅrͪ\ùÈ p º%G{2­úñ¹@^÷ôÎþuõ¡•Á*€ Ž¢Qzèj\5Ÿ& Òaélÿ¼VÀ”Nš\ÃUÉ:Óšf^×ßä>oDZ¿*˜d€ªþ°/l§“ñ«õÚûFåªZqGî¡‚NèùK0·›³GÈb{c&ôb ÞÁ1~©k`?ÉZÉ@Ìð ØÜæþÄÐôLQåSúˆÂ\æ{瘾*‹EìéL+$¿á6P¡˜FÏÎ?µË¨ÿ|êCA~mÏVHÁlÞ¢|ç›~EM717ò(I$,“¤Ïܺî“/üvt,3IÜ«|jV B{¯Ìãã H¯_°Ô»IâLu•4 =³D ï5ÍŠ ¹´Ý@/ˆØ üŸ©#^A®{M‰Zý”¢UÚè«F9z‡vì_ihÔͯÚúÑùÃاmÆ=Ú[d+Ëlš¯ `W³éšâRC\ÓŒAƒ£fÐ-*8sØxO¿¸X‡¢O‡©ý…@tòƒ6âZ*BuõèGl,QÔÙ°T±Èu1H…‹ÎÝùú|ÏI‚ÜÜ[@©×¯”6„§ ðwj¥ö7¿/  t9YÜ2HyÌ‹N+*wv3^ØvK SÊ[3÷½Â²l‚"{ç(øE9¿fdT6 vC ôã«ÇÀC’£ŽêÂìÓ±¸å¶ÝC$ÐíüËùҡÔçVáûtrBç%Çó°:ûOg¹&"RwþÎ8[!aù‹<ïZ‡!‚>#ìW;¢éAeØwme$Né=ÛcZf¼«„7=üåGf£òcKªU¸„Ë›"mëÕYäᶺÖŽ ’úµî•„{qÆAºWôÚ_TC¦ö¬¾t¶Ö=“.ëm(>0j¦|þAk¶@¦tewϤ”x(Š­’>üÅì²Ô¾ü–zxvÅÄD&R®ÛÄýqÃ+aï 'f±ŠÊ×®ª²fmºíx,Â9âp=ß_ÃöãJÈáŒFòYa÷X8í¡šYÜ4!ÝûHÒ1ªræHQóý68‰£[øÎË=g†[Aø°upT99L¾´GÆ…Ø/|¤ÒÒ¡ÑKc•ý-9Á:¹Î_0{y–¯7#Ï[+åcŽÂöš’ŒT¡„$j,ˆ‡µ‚bîãƒÒ…9£tçû›eˆs “xÕ’¯NNt¹ÕgZö¢œž2b}bMÓÒÍ̸öx7ãÑ b{ü”Ovè¶n;–‹ÆsüÊ¡bcr¥Rª?žG!ZCÍÅCôkÅšiZTqf"+i,¦,ˆ:¤æZZ‚ —›†ÎÃn,u5ŒÙTX]òŠÙ·êhA#fz:ßç¿D6©sï-¾œ/YšÉŸ,~ÆhÓÕ_]Wjù]mߥ#¡øŒG˜7M’'|¬q3¶+TJ\rñeUeœ§Ïã¼V3>¹íÀð:U)~ðçªuV‚~& Nè\³‚® ZgĨÓôv UÓëÇyLéôÉû×£œTßCù”öî­+S?7›¼×ALyÅ+,kmiÎHì°ùÌ}§C$>U™­“ ßïpϾð«Œîeí³œÚöJ8ÒçÒœ&š“×nçÒmÌ4WwC•cõ}k‰¡w»Øñ›Õ‚"’0ªóïãœJ!}4}º9»Úºµ:)L1Íæ’ЈܚòÄ#ù¡nS¤"MbÕTóÑÐös•çå‰Dpà>fR)t:ïÇSeëBeª>Þ°Àb0wÛýÐDÉŒúãTßm—¥šò*V®ÕT€ eXî$ÿÁÍ?y(¬¨#ó\Ñî"Ø«;ɨÚ->p®Z¸c½DªK",Eš™¥'„EµM«v× Õs Œž¨sð1—Á’_d9LLZê!ô-ŽR8#øŒ›ï÷iÿç‘/Q7ªFߘȞÁ©I¬ö=[gÏ‹PªHëJûº˜g,7ê îžß+TïòÒ¿\?9”ỹùˆÄJÂ| µQr÷õã[A噶Š¹H:¹”Mµ3O£Z©kúå –õ ¥-=z)í/¾å;R(œh–ÔdÑ Ï] .Ûº(@ÖoÂú[leO6ÚÖ Ý »ÝÌ2E2 RûVøh¥ÚYœtYõÕîù~S_å|<ùPM”üK@@¬Gì¸ÍA:ŒëbÛˆ­Õ­¢ Kx‘?a³Yöm„Õ›\] S†¥—tÔ°Íþnõýyµ)úÿåéš“ endstream endobj 3748 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 3750 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Ú¬¸ctå_·%ÛvNlÛ¶mçDÛ۶͊YAÅNÛ¶Õõž¾}{Ü·ß/Ý÷Ãã·æšk͵÷‡CA¢¬Æ bî` ”t°we`adæ(ZÛ™º¹(8ØË3¨-ÝpbÎ@Wk{qW /@ hšXY,<<u+k³oöÿŒžãß. ½ù%ÿW¤Qg’’UÑ–‘ û¯oê¿¢”ÿjïªîåø—ØÿlEÁÁüþÁuðø0ü½ ¬l\ο¹YXüþÕþÃòŸgWgkO€Þß–™YþÕøÿüýçÉà¿ÀHØ›9˜ÿ³+j®&öæ×ëþq›¹9;ÿUõ_7þoÃÿqþ×¢ž@3¸•?f|!6Ù™®?°ó‡'Åõ~õ±€‡:–7©—Ô9ô~ψØæ©6~¯elžæýìðZ=£L>~z¤ê½ìßǧˋ‡¥à3ÁöO=%Iqõ2v¾o2û„|uçòØáS F©g¼9ˆ¹ï<¼„Go>„Á 2»!–™‘ú-#í«»«í{«¥‘hp† §ÿùiž‘Ê„ {îoQºÕh›­]ì2@s†ÐŸW2ú¤È *W[y÷-¥ë‘ÆïÝ…)ÃÊ–©}ïõæü)ºfRS¡Ü "½—Éë"Æ¢+W‡¬Ëxq„;ƒ’g†¿ÊF5öÅÓY. κù߀j}OñÇѧök%Õ-Χ§‰Vøþù6´0 *æìˆýBníÕGF}TRïLz,Û/i(‹“–þå~ðøÔVx-‡M5¨œÑD2B:Š¹àß•Jý·ÍT&¤ðîûÓljUD ü,+”iÌýØ«Àé<{tn5UÇÜE4ë°äƒƒXŽ††ØòZ…6h-e/×"h¨úò“q;ÒŠpŸ@O-ÐYÙ™üƒÍƒÇJ«à„B°ÎŸ¬|à®Õä>32ãÏ튱_€ý’ÂW9P%q¢Èø-Ð¥¦ËÐhö(mµyô›}¶YEçW/rkjZäÆÑñÁ%ÎgNT:ox R(ïƒ:ÃA{žOŠx­xZ}kZRý؆·(ŽfC_ç‹žQE¸E"y-gF‹¸aPÉÐL§¢r°§¢ª$ù•Àá6RHá2ŸM ’Wýáe‡?ÃRZk)Ë<ñ,MâIÂúíZåK¡JŸ3„åa}_éû1…¦ ØÕlýNDÚ8`Kjn+’º³Œ5HClö±tL’ùµ¬¶Ñ\\°möq BWÓdœ¿óÔgBd±?þ2DM+oW;•‘exkùä¼Ý Ÿ<aoÉûŠ-¿Yã.Ð÷ ‡øÇG¤üÁO XOÇ€ˆ¨œô†ý#Iz»r„k>} œ +ÙÂôBêÒh¶Œ·ŸˆRÀñßže/üªØ?)¤<~!ôþd³ä×+£à øÃïÞ‹k–¨9«¢Óà4®¸6{l2TäÀ0Î)ñ}Š„;¨ÌFþy©a7€¦ìögš'üwúKíÚœ+|V#ÓµÝÛβ"À£)¹ßuÿSŽ—•t«â7'‹Fë׎¸Ñ™;>íœùÕ›ê²`]Ò*&çù0øÏdH/QÑ“œÓØÒ惛p}JéÉ:c52=9ó:µR—$ìq~©Ã±(¤tHU+Óþµ›3°Y0('¿Ëd»¹é/Ñú³½§kÎGASR±HV“£+WÅ…HGæ2c1œU!poSä©~ÄRüx–Q¬¬ù¸w`ë‚™G:àìx ¼‡iˆ:ì* òíh6P3sÞ6vMºªLŽ–ú3ðGWÂbÜÕïïMjã¼RZ¢èdd1šjŽùÔã?§^V$üÙÞó?áVrzµhT^ðã ¢Ä{Ø£wñxÉwÜ_,yûƒ~ßVÄ,~øAŸÊÎkØ,ãÌŸê*òYÍ5™ìø+t~…ðº`§‹d–ô1!ú?îÒAjؼÙ` ~)˜mÞÂËœD2g5öñV×ðOÓ”RWí¤üôe¾Qk ¾l«µ§ƒòÍôؼ•I{Õ/[Žá”)à|Ö"–,nlö0Y¨b™5§¢·r… mP„”ºóÂÍ‘m€Á}ä,¥yóî+x ÄhÝņ&Tï=c”oðS>Çí¢êÖ—›\­Î–„6#o…ÿ·-ŠÆAQãC•6¸'аh¬8qø%Œ}¥çêLŸMKªl”ïùçÙrL ýh˨ u@€:ÍWÓ˜‹ÂõÅ$°¸\Xe ¿(Fm ³$õ›ÿœ– wüm®V ê¹±)•¼ès7lºž´Õo“•HPpÙ/Þ/›‚kXz“ 'fY^‰ Bi× †w;UÎ7Ïô.}õR"Îø2j£ ãT‹;‹ÎÒc°å©wôÉ° @Ù‡GT:ø^)ó[/K ™s»5ýÊ`zAây]Ú9^¹º¾Jõ܈:óGn{›’ä…ÆèÕO!õÇúÖx™t˜;½{­ï­î¢TU]•òâÊ8Bè¹å; Üž?ê¯g}UHŠ²:^!‚NÖˆÍ8*aÿì%öê¡øóºQåˆôe`Mˆé2_æQÙPÆ0üÖå¯ôã!|ÊŒØI¢ åw`èboèÁ—èÊF‰\¼ƒœƒ-èˆÆòÊ ¡ô­Õ¶dIö°ÜÄ’+,LaÅ]®xçJᯑ–S9éÔ|‚jXW5Ÿµö ¨`±ó¦ÖÎíœöb£çR£}qÃ=‘¼‰Ü~þ,f‰‡WUó0x{õ™s½TÈ êÛ2ý755ç©‘/NÒ‰Y2p ¢Ááе`©Sv³æïêY›<˜ÌÙnÉÛ/%hð÷ŽÇ>¯ƒz!YŸ–u‡¼ç%¦.üæßx)äŽÛ•vúÁsàbáv‘vMuć ìéÀä vð’ÑKYP— ÐÑzm´ÁMïô†Óc5Ì1_:êL$2wð›Me·Wÿgû¥¤‚}&Œ²TFDèñÜ8Lí<_!™™MlHðÔ$v6|yØ [ÓpC -»w^nõþ#¹ôUâÍ+üíºþ$pQA¥ÃUÚ~’€l°¡Í¼$‰^2Sïíþ9Ão Êòg–iöÙ(J_¦ÇtX{  U_ Ùâdö׳rþ[Xg0m¿3L¯>#ZÓf•aê¾zã8Ójê¸C첊ؒ$4Ù2'Å5€ØR¶¸R;©½O&•AæÄúÐSÕˆ¦€ËBâK<^è!ïòÞµe~kÕ¿ÍÜ1̘£.Çݳ:Zœ-×͘zn,äœ*Ë4HyXÛƒ®#(ëi±û€-³âkû¾¾ÈµÏß`ÆëÜMä\ú’Nêè¼l¶y’`€îhþü$à¹2T’¶þ…R©ÈŸû…H׎ šG®ÚØ4ÔcÁ»†—ÇB±êm¬<´°úK6P¦ ËöÙ5ùÉbÅѽd YÌ™ÁosËÃ×~Ã)8¥Œp¢½Ï¶žTòsrØÖ¡³ê™ ª$88q©®x^*ˆãë¥úx5X¼Ïs9.®±e÷y*ž„}A›‹ŒpH^ŸÞAiJÃd­³ ±Kaðsp»òÄ_T¼žÃ›uŠuOúƒÑx¡m–õì+*ÒWNNŸ#“Ѷ*zpÌÂF‰1Gñ½%AM©X^4º7ã0.q=9h7<#Ä °.×^$†‘’KhרH„ç)#†(•smˆ€ËC;¶­I•²"†e ¿•õÉÀ¿ÎòNK›±OÖMf‘°œ¾ Û0 N~_Ë¡e*\¬™˜Ð$ýa{Ù²''”[G° |Ç4Diá¥"&VKw"¸¸‡X—XÿÈå_ôEÎä9äš^?;©V”Œf†çs¥‡¹9†ÈŸ@  (Rß´ëï*ôe¨>4û(ÍÐ7¥ÜWŒMFøWe-,o,cÅúlI9Óÿ($æ±ì]W&6Â}h{¡0(r"g¶i‚CK“ØŬ}Úú¯´E}0Âч¬ç^±iX]…ï'ÒÙ?¿´½g@²y@Œân:¨Â@ ƒË 3C®'·,xļã õúK'‘ŒÆPmkªÎTïNLeëŠår†ïÑ­–ʲx;8óGÔ‡AÚMY«[±YP¡O2~æÎ\J««%’Û{) G­•~(îTÄÙ¯þsk#cx‘ý¼ç1ªêD£øÅ'p…-M¯®±aü–ºîrž¯µÆ2|´§¥ˆ ¢Øã°~zp1J#;7›õ*2pŠ½;ņ áQ C«Ò èa)¶<¤DDìü¡<½zÌy(óKQGt$ÅŽÚY 1CT©„”ýæ?ƒF³Ò gé2ºW…—›*âÐsš·z³Ú`°À” “-¢»\õ‘Yï &ZófmÌø™€b™Eœl]Úu4±-GÏc„ªó«è³¹B5ÉI6^†ˆf<™vJ[È2(¦‚ íá! Of•’´ÈÇûŠjª^ ÃçòNâÀ†v™¹Ø‚–%(ºúû7›êkD½õÛÅÔ+-;¿¢S3Ù ‰q mð1MHµòß.è­¾G¯¤Ÿ¨qyá«;Š^að\Áu´Gá$pae©³}Fø´cqõdY·’ÉéQ¯yí˜"tù ýú=Á}™Ùø(Ób‡'2Mn•DÒ?pj)ê¤Á&¤VÎq›Å…íœá$2¾m…6ãà˜‡3*ù61¿Î46¢¶~EÛ´„R”•Óõ(OJm×$ëôAPÁ }”Ê*—–´›3ÚSË0z 8$ 7Jœ\ÕÀ…ŸÙýZ©Bkâ+ŒµDeÌ…"ûuîö¹Ú+lk¾ëQL~4¾‹¼'‰!ИHJù)•«Î¨žg¿Ý›þ¦ã¡!–©s¥–6<ØÒ%.Àjå[—ò·$ ?fÒ~mbzGéGp?‚ͧñ³±,çR¤DÉwC7q{Fw¥xHÈ-¬:ÿÖ‚Šˆ9'Z{+‡oÇÈVvúVUhÐlÉæl³q{÷Þêø~sû ûé˜8ï”÷Îcþ»8¬m¸C@¬&ìGü f‹tõšÕ£ß^ë5ÒŽºÂ»TÐ's"/Ééº=‹’`Qµ@WðâKûàøE îÓæ£9lÌM¡¥¸Ë XiöÇ2J2éÂtü¶°*ß2´ÚÝ2² §2TPþ…ÙDªS#nSXîÆÇ/&ä«*ÞÏYí÷oÛn|7y?0vc¡ “Ñ´pŒžK¾Ñ‹óa åf¦O‘R ÷< ‹ÔÕwÜ…ül»‰=X¨mAí7ÕiHüF#Ž¼< ºqôdÌÖ³tÜ$èPMÇñHý­ÞJ¨[Õ&Ú“½¯Æ°Þó-ÂŽ*Uåk1N†™X¨$”fY#ìf'}#Ò!ñzXþ~!÷¹¿7GË”¾ve¢+ýÈ4Êüå›ÖкŽ(2'}ÝòtPUð]OïÒ+á¦ßžÈO÷bnÜ… £ ¨£¸^¥†GÄÃñ›‘HÜ–E+UGÒ”@˵Nˆ+edƒˆ;ügjOúúEúãT¿€–,]!,9LK­-–.ÏF4z÷(ž4,žÅšÍø$!#}YoBÍ'–‡ˆ}=cÙNöM¤wJQläE,"«žP ã÷;frVt]žüC!Y©€ÂÄ +KšŠŸÚsæùÊf¬2å3‡Ÿ\( àÑ`ªÄ-b&åPT ï¿BzOÃ) ›ý›Ý‘HGoÁ¶W‰»*5åW\¡õ±»z‹éô03~gV¶3„—*ØTúEž0g‘ZŠU*AV‹èpK¡©YC¬lŒ‘ÝÏ܆¥V¼C¦:ˈ€$±Vô9U›LA œz¨cI6¾îþôû—Ñ‘$W—ÐGoŸ'³«D¸,Œr¯%ê휪‡&S©ÒÆùø9ÍßC²x{:GªHÚ}¥|RNðQÐÇa¥Éœ úqÙ¡U1jŠÝLÍ>¯Q ¹sS6öÛ¨Å:š„f.¸VùWôçdÜÑæ£9±CPâqÖ'­£l\Å~éÓà?­§ q)fÁ–nJyÚFÆr zˆQÍÙ|šÞï@%ƒål‡V¯{Ÿu½›Ù6táŸæ’ÚÅ5´RO³!gD)D®!+:¹ž*‡ìΚùy½Ç{ `FKQ³„ýq¡š’öI_Ḑ€áÐ×7Ð*}«¼c)­%k'ð•2Z/¼=»‘€Ú S’'ÛÁ wè?3k /R}™ÐY—C¾ŒIö†xÙÂN¸6ÅM*\ýÇ»{“£³>VÈP0<ôC%onûrW)mKFÔJ”)^àäS¬í{llô+âþlÛÜ&.*ñÜjÎ=ŒBæxH×îÄè;~aÔ» b(a¢p{aªDÁFØyNÏ¢RcÁ;ê!ûlã]…J¾ÀiæHësç1”¨§lΆ3žµ ô(’€mY± éºaÔŒ2 gËE/|¼Bø4ÒØðDDå;†¾ŽÔ“ÐÜ¡µ9‚Ó“¡¥s87«÷ùvè"V‰{¤Vr«oµö6³:!˜“$ ½•zšªmN›5YÑÚõ^C)ĺݘˆÍj@@¤äöò”0ZQWLí´›-î‡øÆ~«?¥î­ëa]7Þvܾꨦ‡^Y,«ù–ËF¿fŸ²š³#ñ»kÆ(ZÙ*¢ðŽôX\6Zè³ÏÝÏq¨]^<“ü¯K½ïw²,í ¸­è’Æ‚Ùx¯™%ä%ŒQíëѼÄÅ4‚AŽKuÙÎdžŒz²&ã!Îj.TVHÆ Õ@º`Vc¢ãg kk/‡\¦VÖ^¯?î^¿oRTK‡éîwácÈ»r9Ñk0Ãö½Npv³ˆ_d—üê•~;ÈÄâu°p¸§|'evæ¹C5×!ɵA‰Uª¦Oû"ãÄMÝ’’½&×ößBky4ûÕâüÇÁ:õÁQ_K· Ë,Rǹç8ºÛ)Ä_"œ~ƒ5p Ó• cp£¾]À©V%pþ².y-c“Ìî*º˜Vͤ3ÚCà#»,g'¹·KFm «Ÿ«Iù 0ÜŠ§t>•U³9L†‚+˜Û.8|\nðŒYzžŸÅ~ ;¿Ãdn1mÚÖyÌû|¬·ë©0Û2œlæVA´¨åà>`&>9jË÷„ֻɿil¹ª˜HúÆæ9e‚Ï’ˆ£+¼àé¡[‰©ªÝâáÏSûùò‚cÛ¸†ÜJðOòŒ¸N‡ÁØW¼îBÄ×ÆÃðz¯‘’×6_ Ë¿W¡À-ççg»¬¤Áj‰*WžtZþ/>>…àÄ Ú Gž«5\ýZ•cÍâîõñwC~é‰ãHÈJ“kª°¿þ ˜–kgh3‡e‚__"{œê½ðèÍF©Üb€ÁÙáðœ}?U‡Ö h|„Ûæ§yq~Éq›}Ĉ¨u…=AP1<ºÆ©Ès@@Õô¥ouUÎÛU”c×díçGߘ)/²Œc±¬]ü0+œf­?œàËù¥n¥QY}‚z}­œ1Qük…È6.i‘ºÑ4’‡CËNÍRŸ…^/«áŒ™†ŽUœ©G=™àjèn\òç.¢û´ôxö-<¬Ý^þ]ð0-͸îDXªwX¯ ‹í©â—[@ H†Q¤ô£ 2^2&4œÀPšND Ùio——U5‰˜¤“  öjáy:¾Åk˜¨iºZpO­|XíÁlÔbå« \?dy‰ÇŠŸ0êZ‰àa5ƒäÛ¥Œs ›¥óŠ³q%Ø.÷…Šì´ß°gבîA‡p0ˆ¾=ú9döbŒÆ`‘ƒNàÙ®fDì&oX¶>nöïÒÿʶ¥wlOpX³z-¦ñL.šy©þ‚VÑÇž<7µ‹K…ìô¸7—ÒYÿ<}xÉ’ñÕJï0:.4äBžœ9ÖJÙJΆ6¬ÄÌs9—k`×~øó®z²¼»%­í8ªXãÖGHyÇåÀS|¶Eúù:å"_ëK\z5Ò¸¼<Ï­ç"â¤ØÃÐÊ9†Ñ£Aš²õÃúø¦½…f¥‰*ñffèê(¿¡¸B"ɧãùgAý$‘‘geÐ6x¡uô[p}ÀÇLurèš……œ_“úæˆDÄÞk:y8SUh¥¬y/û`l`Ê ¢:t3û´mk79=”×ĨióÉGsv7Œ›¿™”àÃÈ‘otU!½§Â²W£‡¯!ƒ€yã«ô>û­ :ç¾ðÚÜ-©xÙ5+=75²Æ™½0©5²„ÅbìÒˆ#¶›g„ú¸ì!ž^ФKhFèôSð}ôÃz>p îëô‡ ³+”t)£ºb‚UVR»½r4­SBWü6;ü R*!z»·™rL/’Ç°KùþeåS+isä‘p&üÍó\ôðNE Ì¢fW··ZD±•ÖÄâÐ ª”5²e¼o$Ê)nQSþRc!¹®£ùí• ,Iu3g„Ö-Q/%'*ñ÷¾D [Œ65¼aÄÙC¶:lÎάð’‹I!C…cøÉ­0a.(6D sM\^ÄP‡6Ž ­«ÔOŒ‘¶ðl€ÖŸ”(’yk–I")»«ï)Ràt™¹€½©Ø2 Ž¿ò©ð÷+1?¦iHZ!÷©M6t× “×µÝs2¾Eò#cíÑ.<ã}æPŽpªÿÐÑö½¯‹õÉo¾GÜ*14©o¿M’;y"°ñ/†µ_…µ‘}¦œ¿Õ=¶„³$@‚'ÒÎD~E뎎­OB {£2ðõºAñ5Ö3-ì?÷©0h½ÜÞü¦U¬I…‰}EíÌ—j**}­™éUê^ËæË8#†>GʧÁÔÇ2ª°#l1/lT8f$TÞ+<gà™nB‹l uˆFî–ç{Š]iŽV«…·-27® Ç©R_©N›ñ#*Þ{N¨ªõÆ[]aÚ^ƒ#Yùš é×|L¬BÝf 5æ/£ô†`"ïF@/:᪠´ðã±|Uï, _6­¦¢T„žMÎOÚ9þJ¼÷„öTˆr‹/ 0,Òêe¶½ÝE¢J6ˆùNIoûemr:ùåå·é•\¿Ùg“Ebü üQÙïÏÁ4~™+RÎ!:ˆmÖ`–V¬+í˜î)“xlëg¶[Ö# 5Ý ÙxoÜÜÆ[Ïß;jµéŽ7v¬oäÊ,ñªv˜%z|xCk¿_ÅÒÀÊÂ!Û—LEÙ0ÚD®šdðãôßp‘k£÷ÝlaêYK¦¶ï×£øaò+‹lÙО={`¾Ã:13ótñ î,jIÉ»=üñÖÇ>;#ò–iE–l]j´ «þ¹p…øÙâµ4¨9`˜½G®½À0Ëj—_]Ê*%a¹Òü*+Îq~zÝEROÏù~,ÕÓIÞ¡áw°j3Â^‘u¾­bòû.g2Pæh]òƒQ‹œJ²^ªœÑq KsZ[Ç:³sƒñg‰“8ñçDa’+À™QPÐ(b6Œá¥M‡z/PfÍ)f«6ƒA´õeÞ”öíž_„ðÒ•ï[“™È}Ùüê–èË2Jd„SÍ\º^úf)N*—V$ò(ѯ ¸ÂÖ“]3w|ö€¾Êr- ×µocGäÙò¸îíf‚2†ÈÜK.ë;d1Aûç“å%ŠtëKÁÂQ9jÛËñj4¬Q´Zkö>â­–øÜbéÎ{õûýjn'£%)çåQ·Ü+κóN:ž£½Ð”^Lh‹^Ï‘›ôoW®ï“ m6Ô¯¡€ ãH;ÄES3‰ålu­Ý;?"çm¸gV2sÃÁ^›¥ZÁ%°Š¢8å)ª'+÷PôÇ–>iÙ™xµ>xQqûƦÉÿØ=¬ín+R˜zr Âu«c/ÖC¤MÅz:ƒ=·èÞ&ÑÙ:ñÓnKVˆÖRË°v/ûÓT/HZ†GŸßŸÜåø¯I~ná¡B X&©®WÄ Ì·¸«ïÌe „* _k]‘w‹­¤vØ ƒ¢[­ÿŽ¯cäõ¨ˆÕÞ½˜‡HþC F+0+emõ3 'ÍçÎŽùr6à줷'™ÓpÊsÐÝ`‡hÝØPÈwµ”£â¯ZCvßd.ÊFSÒaŽcÊbvÁÐÊÉ«½¾„J ] „vºr“|ñ£ªÈ3V¢t´ ïÄpø~rW¯ƒ%×øQh“R‡¶Ôdzû'è-ÿÐHûÏ ìTÎÝTÄQÇÝ*  ¦K­=¨£¦¡…m[ è»_~=(ó 0šZDïSæ$NÖðÅÀ aÝCGœ¾+¯·aº Ÿ°)ˆ*0_{0ÜäçÄ-Ÿ÷WŽËph{ku†\1סpŽî÷±”|ÞDÿLl`íC~ ’Qg& :ßÃÖ ÌS‡ÊgQ’NyÐâgå´÷Œ<ÓØy\Þ:R•WÅ)X¼cc7Ù•'™¯¹È+Þ{Ënˆ6\ÿp¨BA•u§G'[»?âתîjž¡Âÿpó—zbºPWfIbíLÐkàÀ€ªô[DÒ‰¨ÏUÿ!ªµ‘„(’t4îlø¾ØÕ¿|Hm‘Aˆ0¢yÝ߉ Ç;UíÌy^^¨žÌ€ä^©"éz KÆÝZ2ð¤1²R$$ì³û#µrôëiȈq[m¸@L˜µj¬âfÑqÏÛY†0ÖfJ°©L^1ìoõm[p˜N*O¦†f4ö¬†ô¤c_-Úª£ÜÝ|k ‡N@jGN 'õÁM{"ϳÈ>‹ni ¯Ó8ÆÍõq‰ÈÐ =“/_Kßf˜QBÒ€d€âñIŽŠÜË[q…zmsíKŠ…Ù¥Ä3äûoî n<¬}~¬ æË? ¸Õôºª¼:bkuGÉþQÑN¢,îêŒô ÄMGCÌѳø•)V·¢ÙNf\#®¹ˆ!o"öˆ^Ý„#’5…ÒXÖ!ÿn›äËÎÓØ7{ª_o™ßÉÐZ%ô[¤Úœ®¯ðÙE`4t0È‹|\ƒæ®Œ±\Žu•%˜îŸ‡ª8ãJt÷ ÆÊmY×YKÁ^#-Þý¿ÛötñŸ%»çÕªÈ`ïbLð`É lŒ™îŠÊS-¹íª,1¼í3­Ž‚«gþç_['™|C`ô‡ fvð›/Q²¯¡Õ`Å‘[ñþºk«Œìt¢¡ÚÄ ¬=a-ôœä’rŠ‡$FƒêŠ FWkVŠ&v| ã^ì¿Ÿ|„žõmHHa¦v̘ðÄîÞÏjUô•Hs‹ºìUOªFæ âE¦¿.µªT8n‹ƒ~‡÷„m=ã]\$bP”Èâ·QÕ’­~è¼Ù kÛG%ãø6°+û› ‰\’”˜°9ñxë~îŠtLùàŒÆá² 8lÕ*SjEbO+=ÁGÑT᪠½ti˹¡Ôͤ= ÅÆWðd†Îb×ðNbÈ œßD‘–NÈø¦ÐÒüª5\®OˆÇ±&$}Õ?9Ö‚±gŒ8 *äÎN+ v®€U×ÆYF.êîï?"‚ÊbÛfÓùßX%D—¶2FGîo!;ÆÞwht”Ão…퀸/:—€ÍÆ4U•7â~”c0V™mG¼òÍ\šÇ%~ÿŒ¢âìûLq•&ÓX(¶IS¨ä‘1x³Œ™ŸK" ù=¼zÛx'F¿ˆÛ/ƒ²Ž‡£ýèõúxÀ{Ï`Ò´­Ô –÷Î: IWÄõùú3µÌv|ú?AE ¸õ‰ñ)ÉG çì’:ÅíMªEÍÖ¯èo“…^ùû<áþ¬eIZ(,ÈÃî›þ‘ˆuû§3}yåႸ\2Ƶ|;¦tkŽà‘|¬‡¿ªL‰ r49Hdy)É¡†{cˆ\~mõÏ‹ä¤=UqîRF=nÄeÓ2ö6Œ‡—D$´†‚5ÓŽM^+  ¢­æ#AqËví£GlíYÐê ª× nN‚Ϙ£+>òüU:¡$°¤ÃlÂΠņ«Ãj^ùÄ]À«8ÑG5€º â]ôEÿƒ1“Nýlo…_׊&γf¾7BBjëCˆ3?,j¶;{ :A°û:Þ¥`¹“üÕ@RÞä2=Ñ@dóö[2ó…§Â‚ÀxRÕÑš¥UYk»xñ™j¤ã>|â™WM âÕHÍqj…³$Šº 8³Zœ¤ò!ö”<*ÄÇþ<Æ biÙb™zþµ|2ñú£oº˜ÞTYž ]2,0ϷјcîëfS!;Ïá\€¶°Ý -%™eÅD`«4Ü,Êú‡TϘ/c°s zJiÓ"½„ÍtŒÒ}GÑÉÐÍWÈÁPépõ­¬iøËËþäîk'hÕ'ÔÄè©tîNbÙ;xèÏ(Þô!UpêKý©·ûJ¯/ˆg™/œõH‚8lÏåE?g¦_ŠÐº}We߃_ãÑIËué„TöH|ën3Å›J¶•nÓàké+ ë “?Yrh?)EKÖØ0áî1¢…»7ð‡u·CB jÚ´[òÞrÀ!kàlb†‰$³Žlãc_—5‰…ýÙ¼mó-B ñjÚ“Ú4Àý.(©ƒÖ#ØsçÊé;v}”Àýoul B¸¯ÈAvØ%¤ÓBœj#OÃSg¤Áq£˜Š´ðœ­Ïï/ñÌzœc›éþ+Ußgåxa\—Í*P®¾7Êß?xUÙW-)Óðó2rÏüq¿ù2ßA0š¸gú¨¿PÌ]§°•8ÏÙìÆúiùy¼ªØV †b›ÒÍšG 脦‘R†·‹ŒŠ#³ÿº’Îoµ™<—÷lji²ŒÉR¥g‰·àÙ© z'Ý™õ&r+toÎðE:ß_ tí1ƒë-Œ{:ÊãÀWÈÊçIòsCíN¡tõRaiGùýÈÊCIË™ƒ­'˪ÌÎKÐÔ˃ ß“—Å_‰Òue…ª,îNÞòµÉÔþ©Ø½¨ä"í$Ó5û†´d‚úÛ½ºB‘½9J¥ñhJÀT]¥H}¸¯ê 9íâOå6¼NC ezSðR¶Þç˜ A%ÖžqM5#ÁLí}ó¥ñ$æÝlx´K "uÓ®CŸCæäÐÇâ‡[Úd^}“¼µY x†¦Óš|‡nÄ}¸»üÒ¤GjÅè‰sx’ìN;¥ßæ¨N›lì—B ØÚäš}½+Ev[ù#v0ê8kµoÓ^_á<] Vƒè{û!…N½²roFÇq‰Óœ%Õ¸…‘˜[A)“Æf½â’(ɈSÓÝVF~.¤w@°o¼¨¸![=a•ßy‰qMgô-K÷¹yiæ¶×–‹2KÐýqVëh qlVEûøÛСõi—U·ÇâQÒ©ˆ†ì>`ÑímQÚÏAêVE02dí²ìßÒ+3K,Ꭱò§ ß2Ug´YÚ¹ÊÏôTÕu#Ýç ™ß^Û´æîà ½hIN|¶ugJ±àbÚ¢¹w!,ûôsr’´@u©Ø`ŸjhHé½¾’´G™ÚçÑñ±[*ÅÂاÿ¦VÁ’yÇ~y¬Ô'k‰D<=Jeº˜y!C2T#¥«÷7å¸9ØrOâïcÇÞ#ôïö£º]?$ä&M£pq1wG~§_^üš>Éõ- ““ξò`s´æüfoPÀ¾Ár;J§qVÉ:²º­ú ‚5ÿâQiCcÁ_ÊaÝ4>ÌÝÃk]‘|WSô†°¹Ü·‚u‡!^9‡íIž.ðž¢n¥*¢»$¯„3Û€WƒÞ¾m -:P-MÌï(ÞèËa‹ä•œ†ñar ѼÙD§ÞX˜Ò€cJU´Ü¦ -’ëe’RŒÀî”Õ&ž¶PBG˜­cZ©–Q×!—#¨¾~•`W¯¢òÄ»Û"(ÎY¼PH.¥@+HižA_Þ¹Ù÷ï$Æq“²Ûiï Ɇ"å%÷(q›óS'ý,ÑÏŸå)Ôa8„ÒÊÜgs%2öe‘Aõ ªmÝÉ\Q!r"í°‘ŽVÙ3ó?) ´yf‘ÁŠõPÁ,Íîè&Ÿ$]»wå"Ï­îY#±¸I4´Éßž2AÛkW©'Ùp—³ núl‡7ê¶BŠ,p¶Åûh³Š`ýBcv‹ÊŒÄ&fu¥ .x%„©‚ Q¢ÏÂ-™·p4¸Möô~çlJ×ánÛ8Ӝϻ¡¸±©õ]x0B;õ Â&qùƒƒyNÿÁë=®,¢èÕbt´¾‚[õÖòᬗ?HOb8#½¤°_‚£™Î¾º*‹àvË??4Rúú  eäÉçÌNFö2äQÕ~K_R}ü Q‹íQ÷[ù ŠýÃà^#æ>Q}¿‹zID‘×ýH\Û‘¿rè;A÷N­u ÇªvÓÏ’ ©ƒ)í§µ˜Ll‡óùÏZé«0—uõ+ ìlXZCÞ)iϧn5'bP6ž]Dún“X`5Lš)y6Ûy\\>WëFÇf cuEf7êáö;îÖæXüm·ÝòHÛˆó¥`k·Au¡¢Æs¶7ëÅvÒjú£gÁ2x¥ˆœ§Ä6ž%Á·ï&òÕ7Ó¡¾yS·7NØåÙàS´›Õ|¸ÒDw{/DäñþA3ýûýÚT|âüܱ®žLwtÍÞƒƒø!Ô¬ß'És#Œ!Ó­ërE5>ÞwU’j¹³·ÉŸRzï4íZº´“D8T%;jZ|J‚­UˆÍ¼M6bq9œÃ/žà×BeDÀƒ–qù†âÕîÕïC¸‡/3Q‹ÒJ¿] Ë,Ëvæ÷%²8äÀ45¬sV/ß?%1ÝP‹+k9u«!šâ×Ë:Ò·¬ËXÀëÃ4ÆúY÷ôÙ6§ºvá]}Çáö/*y¼±! ÀtëNÃÔ¬þMâfè|Ašz5þ©öˆ)gY“äz´±'_”ÝÁM…è9'²©#!NùýÊö^û«Ö‰ cœïZndËŸ÷æÂJËc”©Ñ%“æô!!  ÇŽ¬3²BÐ1´`V(õ¿$09Œ2(F?Yâ¬Ê9Æ^ª“àƒôYAl/d~F5Við8~/y´-J²¼am€a·Ô‚—P‚c9ÌÇs«Ê~S=þƒÔ~âNÌ>íQ'\¤!“ei+Ví–ÚÛõ#2½Ê(s.‘™SÍAFaV‹½mÄYXíùÍ­t|b–:Yy?ÚzK>Y¾¸Ø¨xÄ@”îB V;·H¬ÒM}NÔÆt¶£1ÿëÛ–7ò³Áᩪ´2x4k³ÃC‡“ ‚5HðÒ¡Gø%¥¬”¶b€'Ä„½g|ƈ¼Á¨~æ‹EKºÌŽÍè{ƒ'ÿj±¢+HB|>S:ß³ËÛ«ƒ„½gÜ¡ÇÉŠh9ÌýÍóò+Y/A=ìí¬§HÙ,¢ç±ïÓÊiw™ ÃgƼsñi“"‘vqTËÕb;)N.D0¢3è 5F †êÔnúíþÖ-ÝФBxA·\2…¦.Ñ7SÚòàF÷…ÌÄ-‘$t»@ð?󹬨͵Ä/þ†ÎCØÄs8sœš‰)ðÎþ’ä“/]¿u•f•/Þ§[]ÏÚçì—Sûf æºZ¤8;à6›}cÍÌîž\oÖ *ÒT…‡ ¨‹ùõ5^hZ&¶]¸–Ažˆ÷zâo¤£ mu8êùŽn6Í XÒ:‹´P¹¨mC²Ú¯ìp»w{ùÐÖDö}oª éo‡š?O6C‘ˆýá»àjX¨¯éÀõ€bfiøÒ?]GÅÆð¹.û¦0¨±mŒaUF¿;ЛiÚ…ÎʼnmæÓôööHE¶e±Ay@¹YçÂs9ëWÔ:^í³÷[Í €QÐ8~íÈcª"}6à±ß=iׄÀ5!ÎP¯{(˜0Ì 5gá4ëÙ%¨S†§M•/±ÏqÉl/üžIW<„žNífîg2¨šG—™it„ñ©ba¢@¼àdîq·æ+ …ê”LLŒ+¾^£Ï 庬#O7˜NðNgF)lŽÔ¡æï »¥3õzó]Q(Þ«záH¹S2Ø×b;S¡+/C¼¡o’jÀ0'á‹A:ä 15\ÞCrÆО–ÇÃ…µÀUžª~_›oFçfpÂ#×ÙÒ„T…Lw¢¿Úöx[ºkµ>ÏÁÏñ¯V„vô_ÁN‹Oâ¬Ë?I³<ýÆjvÓZÐGÊÇuåŠl9 ÊNDh}Œí‹™%f'FPÉ<ª% xÜFؾÕϸإ°êõXYžºV™¾]Œ„àNcÚûÇŠ13ŠµöÙ}ý¼9žõéèX?hV¸è”ýÐѺ”ûm8Äÿ:—ÚîΰCæIOfŸ PÍ£GóCWVÇ<ñ[ jæÀÖ‡Ñe½¡240ÖNd ~&MTñ5UI€6‘ƸüYó&=åŠi:žʹõ¢Š-kë ¶)P¢‡mÞ1˱Htoúâ2㌾Éw)ÈÑ›1ø#I@…z1õÒ!°ß#ïÎñÜØ”®2‰íž"„DçQ6éx£€z¹tŽ—yÛj¿a ©ZiùN6m=%ßÀ\Æ]hQrIUlÙöÚ­:‹m b&/÷×Üæ¤æq?Où'±ÁÌ)§ƒ÷0&ÝrU%š'á›RéDC±ÖeD:“E&ê*å ãÃ'ŒŠý›÷|= ²³¤Á†g&ž/Æ•ú8ï܉^>H0HM—‘ºå¡ -C7¹´Ê®úò_ ²~‘" :à?óxVù›?ëu}6ߌlÖ®.",ÌoÕ36QÐZWï³\:˜*>KE»ç›D&é:“ìŒØæl­}#‰`Šn]EÑMÙÏžYàȵ¡NŽ¾ô߇4`" Ú¿–®}¼”-\=Ô½y—Žœ˜V˜Nº3AjÅ jÊ+ß5èC9ýŒP Æ¥Lm°„ál;ñnTPUÈZ̘ôcj­òÏ´[St¶ók‹‰¿ 9îRmoãdø<ƒóŽ@Ù—ÙL>˜_9û®gåàF~-}2ZÔ)ò~ƒ3†–Ó¡¦5‡¿Óø½¹=æP{]¸YdïÚÒèm)*yøBÁzc´®ÍntaÖ}hÊŒ£ æe‰%ú˜`l28?kŠ:ÃÅf²o¼6î·f89ióZ2Èk‚[Dl«7¬Tz©ÿ2öÖ¼šªøÍ¿’ô‹¹6]Èr¥D&¯E׳¯›×Óe’Ì7py ,!˜› â¹Æ¯<µ¬ßCÔKª•×Ñí YM&…h˜†pLöˆ>FÍû ˜p!”}i~’ˆ=eŒv%3]ð—Jÿºc·Ç›2KzžlñÇ7oT0ž_c×Ë5ÉWþ,V_·m?sR´/,'WE2ú—6ö„…Q‡TŒw„Q«­x[ °Y5¨„éaæqJ…«>d&•\‡eŸÁ!‘|Jë+¡Ò!2RÜ@CG{ˆàÔQÀ¹}á¹G±Ö+{oÚÚyÖÈ^þ‘ÐÌç$ÁÕ< 1——æ¤Ôƒ·‹ëmwétG*†ËýÝg:DZ™è(‡m\Fô±z˜K×lFù?Î 1ö£˜Iï¬Ã.t‘«Î-àÑ-QdV‘õò Un•“‘ê>~–uöMZµs'?µ¾<Î1Ýýù\wZ:H™Ú8ý¨ÈJ.1¢Ÿ ]À;xûràN]E³MvÑd£Ð7ìÚnŸz‚f¾‘PòÍé//D÷ÖŸa„^ÝÏ··_ÅÔ0ÿ:’Ñâ(±$å0U™ùˆ“(óL®Ž9¦ÄÀ?ÂWƒÌ} ñîÏ©© s|Šrª7AmÅs3P[wi¬¤ïò¡ï}õ Hù:³ÚlúljW ó.*59È„á¬èqXáQRzÆWyyK£ùäìÖN^P´>ÈÁÂ6·/˜vv- “¸)G±[*ö1…ËQ*¦NmýOMoÒ…£Pö¨}¹A÷gR½– ÿQ‚à`Öu‹ÍG—„ùmS+žÌ(×eæYš¨¬†VR<Ïâ-œ'Æ.¢>0çÊïN@:¥•»rÀð¨fbj6G¹ì´ØÎý”Åé°\.…²±Á)&&6‚ž±Òß%2í2±w·Ö=ô.sËslËÄÐ52›÷G`ZŒ<…¥÷&åÀô×xæïºέ-Î$V/hrf])rÙÅ;|ÓNV«ÔNVJüD>S°Nð>l)#¥Ô#kv5†$Ð89Û¬P<ÈÞVÞ§ý¡ŠÜ,É|˜ÂÊ»µ¦#\Ë8™Àaãý”áRòo¾ˆ‚êýáŠ¨Æ ìÍ)üéå~ŸŠMùm^„e9&0'|ÛBMÒ3í݃öe€Rÿ U\d¼Hƒ!÷$–pG?O\ŒykXüÝú›Ç‡«ÌËëZÊ ð.MŠ~Í$aÕ…?*Dbl÷÷)Omä‹ðí”eô¿gèí¬ïÀðÞm ©Í³Õl #_Á†¿â\,T)|¶¢= åi<ʼ¹3ï ìV¾K®X‚tï¤ 7Ý_*úv&Ák¥'1Ñõ8ƒpP÷¿?Þ³C.íAÕ{ÕWת*Zyue™Êö©,HÿUÿÆ70P Ðá觠®>¤ bGwÀÌ‘a®yÎñ¡tfB81^ðKýK~¶Õ|Þ™“.Çáði³ˆÜi8pž¦|債ôB3n†+}@§–¤ƒYÄñ´;•I´`ÂB¨br ¬n2s:ºÛµ%¼2ƒ˜`°–Úx 3‰5Ùˆú¹J˜8É€ N' ãÞ÷È'ð›ŒSbìgK„—S¨~q¡(8›¨Âáê¡”» Ì ’Ä°Ú¡a5[¼f:fÔdˆëdá?ÔÀ8wnÉsáJ;#§ô"_ˆo<#Žˆx°m+DW˜­¬feÐ= Ððv˜Žøk–w6‚Ç%1¶÷å2ô%‚®"wð~ÐtCp´œ6Søêðckß ¢,°iÎÖ­)³Ø’[{i%XU}]oX•/Î{Pö^.½ëP$ÉRÙ„Zÿ²FÓ:½EnŠî×Ï°Ä/ëº ‰IaÐãD x¿¸vîV®¯… ˜½ªmF±-gïƒuÛqò÷ŸÞ5…P”Æ ã­}/†»Æ‰¶/è£èù¨Ö‡Ig·‘°÷m‘ªÆ6_}WåÌä¿!8*©•™u Y#ÏxZ ù¶4³¢2*{à oäOænÖ–?³êe7FË뀸ÁYQTno …›¶å”R¿n¨5ùfPñ–èëÑ\Ï7)Ë$ï€Pªv£ät_“©e£ÍKk*Ìš¡MϺ4?‘ÐjèP^P¿;;²¤žÌ;RãR²i¦¡zVO¹Ñ»Ø-ùÂOI´Ãi\ƒ¾+ÖÙÓÕî…µ^<šº´2:4¹sv«¯¦¹ã’Àè!?Ô1ÕTàY ûÞ$¢W°\÷þ½G6»…º\ž+xâÐC<Š½ã~,#ɧ¤Ñz«O…ÙàŽi*°ÔJ7G㫪Àõ{V;Ô/•ïá¶P:ñºzyÂM#³”ºÙ½+±Ô³Ã;0~ü¦Æò'Äþ ^jÒì>ìSÕß0‰ì^Í’SÚN#l6PeñJÜ°‰ƒÉñIöCì`~iÅì›ù`þ7(,¢%¨{©¡Eô~ÖtHÄ$èï/ãwI•/¶Ï%uKM²Jˆë{”dZß„kÙ h‚l¨")çç;5mçO/†Â žœ‰+yÀ œ—? õ^»{ë÷u»&^$Ó¬€òËËcÕ’á ¢{“ú^$ˆ$Ñú½i²äãsp~¸IWAsˆíúõý“@Ñ4@±óKG·$­—¤®{mãÑ äÅ´”’â®xLG%"XD>õ¨D¸® ¿šÆßM»x KkË€>+ÂíOd¦©É¤¸{ÿ ²~0dŽÃ@æ« „/i¿8ZMV'ðgyãìsÆGû©¦*,³ö† d; Ù6ÜFÕSd³ÁCçöIŠï2O»B÷b]ãkærS FXŽ%¹¸óÎ݈:r)% N,vK† „ü4é]øª–oÏ4_½LÅ—³•ßf[Ï<¶sûq|€×«íHì2¤_2Ü9~ú?Ûnº¯u? ¶ UÜ[,õò:áPn4œ>ªnŒEyØ®²×1cÛ†1.÷ž*6û/ŹkM½\< ò>ø¥éöäâÜìf>æŸ ¥Œ÷4Ñõn\‰ÕÍr÷Ze/‡¯â<[îØæØ2:› à‡E³2‚›`CÆ:ŸìópÔì¹D”˜åt¦DûóRܽh%yGÕð7}½ï]ÆÓaá°ú*¦£…ñŒ1Ü&?f8#Ê¥šöD‹&(…0z¦³—Ù°´Pé5sF;ƒ8Ïñ=—ê endstream endobj 3754 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 3756 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 3758 0 obj << /Length1 1630 /Length2 19907 /Length3 0 /Length 20753 /Filter /FlateDecode >> stream xÚ¬´ctfm·&ÛvžØ¶m›•ŠžØ¶mÛ¶ *¶mURQÅÖ©÷ûz÷î±O÷Ÿîýc±¦®‰kÞ“‚DYAÄÔÞ(ioçÂÀÂÈÌ P´´5vuVµ·U´ç‘gPš»þê9à((Äœ€F.–övâF.@^€Ð 4°²Xxxxà(böžN–æ.j U-::úÿÔüã0öüËßHgKs;åß7 ½ƒ-ÐÎå/Äÿu p±Ì,m€1%eE)µ”¢@ ht2²(»ÛXšä-M€vÎ@€™½ÀæßÀÄÞÎÔòŸÖœÿb‰8ŒÎ@Ë¿a@ Ã?&z€ÐÉÖÒÙùï?ÀÒ`îddçòw.öK;WÓ ø«7³ÿWANö=lÿÚþ‚)Û;»8›8Y:¸þfU—üw.F.ÿäv¶ükØ›ýõ4µ7qý§¥ÙþÂüµºYÚ9\€.ÿä2L-lŒ<ÿæþ æàdù¯2\-íÌÿ³z€ÐÜÈÉÔèìüæ/ö?ÓùÏ>ÿK÷F6žÿŠ¶ÿ—×ÿ¬ÁÒÅhcÆÇÂú7§‰ËßÜæ–vpLÿ슌™=€…ùßzSW‡ÿ°¹þ5 êv†æoF¦öv6žS “¢½Ëß”êÿ;–ÿûHþo ø¿…àÿzÿßÈý¯ý/øÿõ=ÿWhIWE#Û¿ ðïø{dŒìï @ðÏ¡±1rúÿÅÙZÚxþŸ¢þ«·ðßåþÀd\ŒþŽEÄÎü/5ÌŒÌÿVZ:KZzM•-]L,fF6gö/½†)ÐÉÆÒø—ÛÀÀÂÌü_lê–&ÖvÿÀñoÐÎô¿vð—®ÕÏ$".£ª¡N÷¿9°ÿrTþ».êžkûÝ(Ø›þOáQQ{€7 '7€•›åïûû[+»ïÿ&å¿€XþSV0rq²ôèýí›™å_Ýÿï?¥oÿFÂÎÄÞôŸÕQs1²3ý»mÿSñÙÄÕÉé/Éÿ:»þù_{zMàÖWìMøB¬2²3]°óG¦ÄõúYÀGBÊ›ÕKŠêìûü3"öxª ßëC[fx?;=—Ï>ŽdiõcÙPõ¥ÿø’Ñü,Bݦìæ¢ûÄdPŽ˜y®ã}µ$¿ ¡ËɬùkJEÕ ìŠp¦›Í æê‰&€Ì­(ƒüÑÉÏ$½)óJ ZCñÙ9eòï§Gª¡ñÑ‘á¾ÈŸGøtyñ°|FØ~©g$).ž†N÷Í&Ÿ¯n\Î5Ë9íZu¨Éî^øo+®Ääq{è,™—lDæ_" ‡ÌÂ+ÆñrîÂÃàãXK’é‰'ÄfÕe ¬Èœ¯qn\4 òfXg¯ñÄY·D¯He•pì|¢jR K-eë†%šJk2s£dªèhF Ìr±7â QH"E 7ŒW¥ì —Æt»øÁô‚Ôªg 6æž+3ŒX‚3IJ»GÝ;ò3 ëX…ÑžÇôã|HÊýœ¸µë°@ÄJwÞË¥Êèö(‘«*½œÔiq¼fhj¬vKr|í9¦«“kY5X¸8ùŠ®·º>„_ã_ݥγ[ §AiðûÙ0Y6·Î|›ä³ÀÁÆ#­èçpñÖ¢Ùæ8è8l’3üÖ¸³t‡¦#%Åœð÷ùØ,ÆoÎu* 9ZæN¿¾°¡¿Í7¨=x÷vØÿù,èÈ ^FÅ’Sk ü‘„,¼œ‹I×ø`.&@Œ8zBPº£H>å ð1›kKúô! ˆ>Q¸-è[#î Í°Eø&át:#Ü.åþ:QAy~#Õ³I8±3âø3s>vš¾$JR-¿Â RZ^™ PÌB jé† ÜÿL<‘ ¥šo&¢õE6dU½X9_e-KñIèÕ?Ÿoj ± Ž}o­=ÒÒГÂ5ˆk®‡/©&Ͳ±pë&ÿ:L)¤2¹ÏçÖŒŸ'ðmøèc°´~5{†cäýNwJŒ¯ÿ'Z0m[ö·=©áû'jþPŸïþ(F 1설~ù¸%ØV+~ã(×ÑÜÆýü`.k¿Úqu$p¬_Sÿ+Ûy5@t°s{c 4u2~1 ÚÖåI^ì!DÀ>Ólçãqó]oÇd¾Æ?X0"x1•§¾{`ZÃ82áˆuØñéúœæò–6…nÐ]¢]Òâ-"ðÔÎXžïðÖ6¿o”¥½fó š”mŒC¶Nzq¡+ëë.óÇ®9ÂM7{X%æ7kNQ¦N’º —ÞrÔáÜ©ûßJB‰´Ã?#rÖvòù @söVÉ>ªâRô(­a*Ù+˜"¿ÈÂÃùI eõ F¤Ðïއݱ<מkÐùù¡Tiù-.ë€ÂICþ›*ýjŸ`÷ÔÉòsˆæ+æµf0EŽã‘¡¦ðù¸üˆ‘¾;Ë2”þm”ŽaõCÜ<¢xŒ+è)}š*n¿]ØØRœÜzØèµÀp'yüR°±O="é‡i€bbXQ“ÛÜç/3Ik©ó`3ÐbIWjêä•pì)ÉK‡ÐÈîV÷d->„Òµsèóæ÷:ˆSƒ(Vºba2)ÆÁ؞ܼ]uÞ|à­›KÎ$ù „¸œ‘ÛNG’©û\ þ}¡÷PJ·>›J‰Ø½äQ±º@Rƒ­"Æ`—ØÍŒêËú áÐA2žTã0ݪ °óo#µ<­éÜvÚ ¨?$Vì +lÒBq;š!—»ü~0Õú´‚H訋1›Åày»o¥wÕ·à"NáÕ™Ã)‚\“ »ì÷cr*(µ.Õ:àu¬ !¯ã˜÷Ðd˜¿˜ò¯\€³¾B•%ÖÁcç®pŠ˜½Haµ%P­Íýx7#-Û<%Éø5Ba™ ßW¹³g ÐSÒÄ)¸Â1Ÿ )*Ŭ{Çß°2-7b¤†hdñAºˆÑÔÝ}£1uµUþ…¼±ß›ˆ{€ÜJÏÎueîÏÕ*J0ÞmØ/ßû{ ÞCt:Ì­á䇽tðºÞôÑ;æÕã˜eÙ½$ÚÆzžÅ úðˆ·Bœw^3¡çÁ¡ wÕÁëXøæu”Xéö­tO/âyP±’S¯Õì¹!4Ht£2m<fAÇÏ€eQn²Ã‹M[Õ¶uÞlë®ê”r[´Úä¯Ì1AÁ‘®f›Ù@‹Ù6y9Ì gÏ)´|l£Ýo¾Cv°i¿´ƒ2šiÈ m—óå®Ú“†Ž„ RWî³í(žI:3[­ötp±ØÍÝ´ò¦±[+ü1!ï-¬‹ª!ô[0¦€Ó§ÑI£ö€Ê^YÑv?hï³âD)ØÁw<,?“,zÿõbļøWBÝÄñÙåAÜ v-„ví®ÃbÑuÎbXÌÍe,XÒª[—~Œ`»F'ò²ÀŸ«'ŸˆPT=º×AaÃy”»yl›fœ¸¾©ºÐ¬‘Y'Fš¦ªs&%†Ã ×gŸYkQä ß}Û·Òû×^X²Îàê½ê–*ô“ÓS$~ÏÿªìYlUpa…Ã÷ôšáæ²mhzÔ4eí¨D(y÷í„"3ò*úUtM¨Ä zÇÞñòŒÜ ÏÙ·ƒÔˆãƒY eN kÜÕÈ@îö˜–œÈ<ÜšoÄŠ$ÒK³§„Nfóc4*>¹u@iJNBX½Ì Ä½—8ZÓx«eC)²·­j¶C ‘:Æ|)âõ2¶ï+©7‹¼wIìtSˆð¬÷TñâJ¬ŽÐBB›r’WzHsõ´B¦2ˆÞ]YP/,ÿÔ"˜¨”±`H ‹êí;xϳ“õÔ¾lÝz7%º“ZW´6®È‰Nù„'ö¹B±Ä®YÈâ'þFDKA£FáUÚJËÎ+$§‚h×´ÆäªÔ[÷¨ u›Â͈åÍ ÙS` !KíãÅ"®'AhÁö¼ºÿf„gÙî™æj6?á`DÿS‰Zª˜sµÙ”(<ý\ÒÀ+(aâHWÓƒB÷™$#ŽvÓ]1^±À4=ÁÔAßaø\ä7ð#5§ºO>ñ5maŽ»>Ýuq²ï…*6TøN´L0=äøXušŸNIØ™áMÖ}÷³„eÓt I»LV‡P F'½óó‚jr™X(Eýæ…?¡/¬áb_ímä)xÆ\¼™µ*ç‚Ë"åcŠRLþ–®»Dµ¥ÜÁ…ó#*eÈk#ûv‹Ya;Å+÷ ½—_Lùx¤¸ÇÁ1y©nGW$`C•è; PŒ»±Á®"fEî0l~#,%”…ƒèŽgÏÐc+Üóv@Ì+¨d þÀî˜Caù¡ð2D/òYyëð<×BœÍ^RŠ ƺ„ò¤7ED³ YÓR(E‚¦ÞÖ­Úû+v8™D<8v ôo•Ç)Nv;%÷˜+ê畳üt1ªOLjüK‰fäÊùïÅ!„©*%Üþ½½¡©#šž 6ù•Ò¦à}IGŠösþ¼@zãú`Ç3¸'ƒOù@RÅ/Lû&ü›"G²9@oç~É*%åöýî’KgXÊo¿kK|ÇŠ*v[ðsÍ=ÇoñFÒï¢òCNÂþ Ý_-¹ ­IÜ$ï³–ß/눦 ›ñ â"PÂ3`/ rŠa$$Ñw‘Íù4°tâ[;Hƒ…÷ú?ð9CžÊì¯_ÐNbqãÛ¶%rD±Ûè÷lKã øpõò1åZ¨;-¹Yô¯¢°sÚU! i,¦@ºþgí_<®p·Mˆ ѵ†5ŽIŽ:Þ@h"OÉ5°µßg?yw¿©ÊÔÀ‹>Œ€í[enšÙjW_ `„vY—£„ š’f$–Eö(˜Ÿ鮬êþ†L EâFúà˨O#¤À†;_‰¡OG•dÕ¬.Ê]*º¿Ty*jõ`‰},X|Ì•å/kXœÄ®—ø£¨B`æg^”âNá…Åè¿cëÉÇKlò¸ÌMãÒðÙm·œÊœda´ c²s_æ}€‰œeS©Š’§·< £3‰uŽ«¢\g¨Ô&^æügAaW™#Kzíº.¦óöî-ªœÝ¸—¼1ò~ø˜ÂH5Q™*DîW3õQ3×ìíÆgUU =`f^? øA#æòæßû9ä#àiÄ:ÍŒÉÉb›HµŠÃù8{³¢4öP÷¿ÇÎ9H.µª‚e•":ý™V½ùøyêäzòÈKÅÝšÓ®=ƒºàâ³åžš¤R Èñ@爛BúB0RWíó›jС=14ÝG3 Ü<Σ‹wòç ˜—l›Û“ê×Ôv ágN ÔV>'Ötº³káoÂÊp­#ß;Ä=3©[6ܽbæm^T”&…¸xë1QÕË-'µäéÁLÀbL‰ðÈÉô7±×²xâëÅ)„#[6¥¤t‰¨÷0‰ÉåÀ ô1D"Ø¥í¤å[„ÍU=â+“9×ÊËŽoê/zÂoG0#y­0É«W¡íªËÎðë3¿ÿ }á¦æ7,/ÜÝíW«à`ViŒžc¡Ù=nq:áÑžÇ0¯½œY ÊݵóðܺääÁ#Dåïð´lüfÚi­føäRš†æT÷Ñ®X$:V¯µ÷Ø"8ä”4@â7'¾?EÚˆýêÐ$¥âÕÀi¢!Ho°>úÌIóä¹úäýÁ‹û0ö± ÑC@3A÷›{J‚äôâ5_…À•ƒÜÈïÊ?5˜&¯^x] l<¤¹~u þd jC÷&`ˆP𡪳+’Ì8-ý¬®;5¢éÞ½é~ï¤ãÛ}2ù´dÚÔ^1™’Xǧ[n|º]e!!bÈL· u!²wt¥ò‰TJÞ¡–ß¿Wñ/ŸcÊ!ã¿ÒÂg è`I/òÙøgáìu¨GßÜ«hwù`ãÏ£ÛÌIœnSÝ ôýjÊ2³Ô¤®ð”™FTÀœ†²Äú³=29r]:êº4ÍARç0ßqTË êQâ´Àœéã>oÓz†8§pýcv´È½à"k”½ò+¹ù˜ÒÇ`GQ/$z§Ý:\•,ˆåãdíŠÆý•ê$*ÿ±LÊk:B•"@r#òÁµ‡]zJ:—>OÊÊ>²r†ï æw(aë6u’3AôÉàm¶èêjîf½•V5ã%þ¿óšô9H$+$ÚüŸd&nÍ( ÍÚulBMñÏb7Y°1äÅ|‡!ðñÐ?˜ªqY ÁˆááÖ·«8I‚høœá3ºì0ÿœ~7ÂÂúÁ@úÐÔ²pƒgR÷B»"Rö>€PcȘ|UYÔM_òÍ:9‚k×un’Ù Û9Ñ­à;k3Ⱦ  »"ŸÄËâÊ%`lÂ%ÂqÃï×g–FÖ)éu,8Ñ”hYÑmãR?®Nr›ž*t(ùF0Wø·éÂÞx˜"©Í­NmTBb-K"Äî™/'ÿ̳Á•úÕ ýÜBO;Ç|´øÏÍ­µ³±­†ÐgÔmžš]–¯XP kŸK¢Ý?WÈFT÷›NŒ ?cÍš™„>ƒÁ¿Hü'’™bx,u+oâýuÏ`n ô³1c°oÛ­Ú-£W¿$v5%ÕÆä=F nÛ3¦š©MoNPê`ÍÁŒ‹¨´AX<‰gNþüÁÚRþÉ÷Æ8 Mî\Ñ°9î=îÒ¦þ¾7ÀÙæÊXܵ³6‘ôdàoQ×fsÕËVI=sžbwõŠ›²£*&jÙ dÛ¨W.í`[‹|5Ü…Ñâ#ÒËíu_™j=qÜ/FË"ÓÞ…SQ>S¶â™Á8[=䤾 ·RKw©J¨!gcÝÏíC=w+yÆž «zÛ'vä©»x=–7C|ôo&ŸÁžÖ`K]Á4ˆïë9HE2tPïÐófg½,"[çÑoýÒé;çj’ç}kH w±c¤8Û¿»s_½‡Â~îÅE€WéúXo6¥ñc]ÈŽ2ßL}›³¬âåœóPåèeV¼g¶pT-lD~‰_äŸIî½:czùÒAíémN|³kQèHÀµš>»š˜Ý`Cè6Þ=ql0šŽøtõ&=Ú6 b¨œÛCtÖ&ï'ù‚¸‡ Ê\ÿŽY¶Jy¹fßãÓã")C™&ËeŠèf?î+ѽøD"$‘fÍ›”¦S[T^¡£jVvõðÉiRýæo§CókCü¯÷2ç;1¡˜Ûièžeb[<ùW\ÇÁu&hQ«ºaÜÑÛÉÙ×)#¿õê 'Fb2^Òïä¤yó¸I ÿµ³.J…v&¬Z¬ScK\J ãó%Ãü¹ç?ÝËçÎ;ÛŠ>¸4!K:‰ÞbgÈ¿Óö¬ÅRÆØ·™väiTTzSs á/Ú¨Î|»-GŠGÍg¤iÅ#¢eaÐêqj–º3PofœQ3‹ƒ‹;åøâß²„ï–qû¤hO5ܺÑr–l“`E}dÇ-›DúɈ`±2 0D Ž¯4v <‹Ñ½¨vˆävêƒ9Ä1Wapªl„5ñ W‹#ÑoâÌHð¨©òå®%7¼=ÒH[‹bOÄÙŸl¬s¨õM­ðñÌ#6¤]2ßÓ\øáô§'ªÅʶÈÌUÖ¯HÑôÛ,ý5ùÆÆE@¹Ûmä¾ç ]áf¹»ÈÌÈXqÞÌìu½u¹™m#¹Mûp04 ßG|á-\5×~Bh¹ß‚‹, …RÕH“RvòI 2Χ¼”Ëà_Ñ ¤ïw¿CТüŠ¦‡~Èqʬ§u=šE9G)smq苆BÚ¥©è8ÈÃ-¯°E‡ÙΑ×Þ5ÇsŸªÌb~0˨Y}˜ëQtÜo$ÅZÎÚˆ»)XÆ) Ž¾æ¶ÙØP ÿ¤áèÓÛM3ó×èi…R๔º°WdM]YÍCÞ´.m3õyú*œµoÉp¹e¿Xüa!g q‡¸”æM™ÉÎûóA,ü”E»þ£óÔý1ëÒ¥Ï}žõ³gÕ1¸~ÈÚð'k]qià5Â`©œŽÏËzhÈ{…áÅÐD¸—¡©TW´DR²ËdË»°2YA½¯!Òã±ú)W À|‰ßúYãUá 6MFâUñ»í,ø ’ tþ¨©FYÔ¬Ô±LÃïÈ.:aa;,Nèvè=Ü¢‚‡‰ö—~‹õÅî/.Vò§#ûÒV,k?Æ%¿8&þ÷h €TËŠKþPCë8H šœ]lC}⚶wÂÄî¸tÎcëBi‹‡h^¸=[žËL}UaèKJ›Â×$÷ŒÒh ?WÒ‘þ²aÚâàžã‰³?ÁŒU¾zÖ­ë & £hŸ”^’¿fÉ/`*^ɤ*äë«ñÒóks£¾FÌçzyÒrëQƒ6d“@ª!™.¯}±M,Òq2Fhý¯áAw¹\KÆQ5ÀŠ…•²¬e/¿Y““úÍoM§œ7²0Eï3g2¶fs:alQm5ógŠ%œ Äù0y"rÃù¥”ZgòPâscœáÓ‡ÈX(;Ò¯9»#';U‰g[èô†ìPDØV60yLÝõÎ|L€ÆQr[eù·™º±W¦f^âLP%ÌÉŽï|^G­0F É{„/Ö+†X…Ý(¿€ßq5Îe9ߨMטµç+v\ÑÓàÞ†•ßŒ&íÝÎî¶ã(å•æ)ôÿ>vž=ìlÙq­4¼úÄx¹sÕÜͯªsÿ½f{:vFògMâ8‹œíÁe¹jÔF¢/ôl:ÖËÓ‚¥‡øÞ×ý³tW™ªPÇM‚b„£!Ý R­6¹ŽU“¼æðFt³›RݳÓv组ÒèHqø- íP¹æ¹Â§ê*‰k1/BÎå'.Îz= î3X»Ý(ä%ªžr+ièƒv¬9f_Ž‚åcRK»«[“‚Ùsž?ÊR;,ö¨82:×mNÇ}'—÷î.e=ò= €Gú([ ¶ÀŽÑ<‘廞ÓÐätÌ»(!úÂn0Z 2J¬-eô;dm¶ÌP—-*;ïb«êÄðlÃM6¼ã"ד_Žö2²sAC¥Ï$4TšþzæPŸˆÆ T?Ë¥_Åÿ [ÄTà@wÕjù!²o¥‰ˆBD-ËhÞÝè_B„ŠD¯»©P°$ßeœ^K/UP/1ûžyï%5@ChSÜ'+Xvk3­‡ý €N$ÚM:˜¨œoœÞ•žÚ$CE3|æó„°ëˆ€Ç¾æBÔBþ-¼ÃÐ ]ò ’ð<,Z´öx§]zÎXg™J{/ õ#¯šnbw·‡G‘—úœ·"ãºe9•ÈÄ@£wÒ=G™P;Ñ欕“·/³—ƒø KÖÕ‰i4çÅBÙ…—È!²¿ô`&æêè-½Ñúû>{Mð5˜³»¹28¬éW†$ã[*yt¿ s]ÐeG/<Çd¾yHLÖÝ~Yë[6”8;wAnéþpÐîä2ƒ¿ãCÛR!„÷óí8kÞÝtÏlŸÙ©²ÐvHAb>òèÍ2§C?‹D’?ýxÐ.àwÊ''h¹O+ AÀ °‚j"Q98ßþ4¥({,o÷Ž©äøDîä#"^€øÃr¤ ‚ £¬ª”áw38=æC©ÌÔ·CUé².œ‘ô–¬,ò[ɇ0ÖÛÂ6ëZïͧ+T˜*>>œ÷##ݾmûα â t¹[wåø…ÈäÜ‚2¿š³'vpY ÷oÑQ‰Ð–mÅnÆ v3V0}–go{ÀeR5æü‡ºy¹€5ÑE7êbrfù¸0ó¢ªþŽ²¢§TW],ÑE{ÏÓ1¼¤]t4µV½išv;kÆ Šoz¾ʘˆôEUó,%Ï°ºáS¨|Ép#õ%;+;¬7ê @ í<ú9î 0šny\ô‡ÇQ-2¿mNœi6îì†tä Pø›5-ÄÂ@s~wÇÔ×ÏKoÊL²Ì'L"=Í[Šå;C ¦B¼ÈlFåÒÑW[ðõÉÕ˜ksPñ½ë6Pe«}Û ãVä„LÏȆy$0lŠFMxæ•I.Qª+aÏUÐî>öÆ$òr ÷‰Å¯¨ûçi>*êœ0Yö Ù5”âúîé©Tîî¨R,­½ÈLßèïr.'^êŒS¡ ÞDÞÔI§âÕÏVà_þm‹Z¢%0¯î˜Ší¾öªÒX)e¦LÙC)^·'e8ã|i{“#0¾ñ½NY’VB¤ ,=£D>7g®3RAÕVÉÛØÉ~XŸ.XucÅUR..ºVª^ÄÍÚuŸì¾Ònˆ[ñòcjpÌÛΘಂ®†aø Õi ¡D’êóQ†(Þ«¦É*gKvCõø»2ýÄ–;ïòã)þÁd¥Í%À’ø¤äK¡¡¼\j%Õ_ïàª[,?s£Ðå#Ë;UˆzÐK—Ͳ…ôyj‘_­&ƒ¸Î& ÔRªØ~qgÔ3pY}ÃÃzÇX¯qY†H¨kaë×%ˆ±WãâºÉ´Ën3'?¨B3èkXE㛵ÊÈI;ÎÁ[àal´Ýƒþ$‡uãñ…Ú?‚å²¼ðד­þ‘û‘[ö•ðÏjH½»ll žšXû^Îa†•x;(’×"¨ aZ…*b3¯5ë _ì§àU¥]”´^û‹.‚f’ž½ŒíJµRò+IñÅÎþû§5Rz3O½k„öðÒé¦#„ ÂK Ç¢8ïÏ!» ¼‚uì·¦ßV!‡{%”†¦6ñØÆ„ÞØr™ËÇvtTò J"…/“2,ŽûýGi¢\ñëCО[B*¼Ÿ ý:+ùE´ˆƒ¨Œ%™ Æí\üSW¾VÃÙ#æ–âS§Ý»ÞµsÏEáó¦—™– 5“þ‰lÁÚ¨T ŸúðT5sîÛl‹‘¥Öië+ª¸Äòê«2s©îÐ2D÷aBÄõëâ‚ÑÛ¸þÌü3]Ÿ_Y\8SÛ|MïuT«Å×à£ÌŒZ_A91¾óÃRU]Õ:6mìÜÖ’dÕ&0]5]ÞG”;—ồezÚ]~)DЯ ѤÇζù×ÅÒ¶Ó"¥aÌÈþŠ¿U˜R™ò¾_k¦Mzu„²² ©Ýr0kûVÜa¨l·ì»l•Wæ !©°,ÿUs­²3­3º16v¹cyqž}ÌNø0Çyèb¡åtî”Q,[­·OGž£sðT° ¸Þ—±~£MÔ”(ºÏ”Omr†ì¬yâ×ÊI[$y0¡d=<ÇEGÖuÛ ådl`iBËÍ>ÉÉ:Uå-ÛìVµLýÙ_üÍ×BiVû¤ ¾ýô¶d뱤5‹öŠòp°fW²Â…-jX´«]/¯*Ô?C¶ .…HP€+ÃJ•Ü/d”Z‘ê‹­»H+‚þ4ÛR|—È÷@]vü­àŒû·æù…€Nõ«i<'3 µŠ)ü#% Ü–FÀä£à¬LýíaKtkãéŒ  ˆZ=Åq€æBý±­Äã(’h¥?ô¢<¥šhê{»ŸÂ#¯Ð£îP‰W-0TÑð`Î`´¥éY¨+­‡b†cžöj4¦ÈŸ¯ÑÊMclþÉÇHyjm©¹”I¶Ââ<\¥ å9)þa®¨òƒuŒ¬÷œ§P™¢7γ!=Î{ îÎ=ÈÄ¡ýj²Å/°öãôM8ž”J»¦06yŽ}aä}{’ƒï'&F”D”j[œãêâì"±­ùùOGÅÙ:ø'AMxä7ößµÒEG]ßQÍ1¡³M;G#b<21Ä c¶ín(yŸ•ug&Û^pk.bu¿NšN% ZG¿é‘Ow´cHŠ2 t–Tt‡,Ø ¦eÇÖ5ªM~XAL±"þ*$fkzô„xÆ.ÁÓ‚ÊýàÝQ=GBI{-d=wR í­ñªÝ1Ýg °r˜‘Á‹Mâë}š½J)vG¦ÊÈlü.žl=âQ•y·[F$:¨ü|VjàÃó®‹9¯Rì¹d?_7çÝgÓ÷ŵíM5¨ds§ÿÀm¼µš‹ UWãºw±]©ÀÏ.EÌItCi ¼ Ýßw9EŸ@|»ãqõEÝ,:í A§jÉUŠ’M¶? ·W™oXíÛQR¼$ä –gg© ‚fùAKÊd½ ýcÊÔKÆlå'Yop\ÒñÒ ßHïëgdð5„JÚ¡ìs_Ë7lI(jB?’=sÓƒ"Z.®‚勳ĘÝprâªvÖì_ ‹*ª÷ø…›ßx{CF‹È%ÕÈ5ÖêÔËö_Öq+»µ”}~ë¶i}¬˜-"2H¼#¢v {4Z~~g“3P(Ðþâ–B´qÿ´nYÙa±2Jk#4ìCCÐÑs ÔeïXhW&6Ã-.)tK"‰!Ÿy¯¹µ•g¦ÌÔ€ßl±‡^Ûq¯ËF« )Ë*²{q^ Š_â³¢[*`¬¶ñmâ ë»{ôA:4Ä>|ˆXßÝÕËDž!s§ƒ“…¿¸:ƒš§õ醻㧊ÎGúâd? WzÑ Qb¦ˆNÖš%Ÿ¯¬±—Œë^Йá|®Ê’ïìg]<“•sìù)wõ6VN\ç›qî Á4¤¶[Ý Â)êT4ã`‚ÆÐ×$““¸y›d†€ž::6•¤üxX[<”¸ó´ÒÎl>¢}ÃÚY¡Êêr+³œ¹1¿ÜFd:ôTÚ¤–R:o–,ò ÷¬6Ÿ£r #²c2¯ ò•]9‘0>½Kxo€b°V‚.w9˜ïE£šD|ãVrRX²Â=!ëÁ°N¥H¬Ì§bû¤ú?;oÄ'\á+TZù™ã`é·[ضoÓ,ÖVÑèêâ͇Qqaòe|-ÙŒ“±7IŸ`¢ K>ŠZ©¨I¹)„ßú‚«zIq|0„ÁP2 ½[uFµ'Ç“€.N<¥ƒ`±7λbX:s#ÑÈK¶uEZäHÃCk­²zBÛIê®èï9 §Å]“ùÞ9 ‰Í·»ŠÌÙ mÃoœHk½|Þ3߶È~ü†£nT<‚kïÝŸ%jy廑Rä¹ÚüÚþ¼7D/hÞÎft?Â$Ìc›.ã)O[ÔG5úÎÃóV­Á¡ "›k2¢õñxýºÒ«i|Æ•š73L ²CLupêÎ7ÿV¶ù³¬RRL=Öér%­ÂÝ@²eî0¦ * ô i.ö+R: ïbãÉelÌúLWTýZû¢m5¦¿gBÐ -‰œrÚ„k¥+à˜,¶l$D졆Ån¸<ˆm½fy.dëÅéÂMÄ8B´B—â½UrŽç!›Lj(íòg??Þ-Åär'(§<Ë˼ªòÉÁ…mf4²%ñÑŽ·Ì3lm è)*-l4è0ÑQË`trØÚS±Jbø _2íO{ š»Œ¦ÆGk!¤ÑÖGi¯ÿ±²’|ò˜\:Nî¾ù¡ Ö#|mÊ5¸§œ×6­¹²% KNM _p‘W ’ÄO‚Ø=·ß ÁÁ‡ï±gøI±÷Í»¨]¾ž¥÷x‰›Ïþu‘¦¥Ûêõ5ýdÂÜÞ÷Ùdž"sJö³²îÅ!wD`¤'6Œjf_±ˆ]ù9ê\¿ÖäNFa]>“ ÙÊà5¸,ñ[ÈY©^06ÒD‹þ¦2¼š0»„Å•%>îÔkÉi‰¥n±Oó`äÈÒ]kÃïétÇ”ªw·[ÌêpĘ õé¾v÷œ:‹ù¢LôX‘ÀyZsZ[ÊzI倫wqMy»°šZ76¢ùvó÷[¹¸)ƒÿyc’LŸˆ,´å๒ݵš’ÆmÙFÊúc\/½¹ÇÌ{¢)…Œ·ç!J¬tn‡OÚ/ æ ÓGÓ ’£2±üÊÓý(eÃÅ!Cø‘ß7÷}´«µ<ʯ˜Y7ѸL ãƒ÷ˆBBsªü屑†18È…ˆÛ†£ð]á #݈ӷ+äÆ‚Òþ€¡Ø×Âzþ•œ‚f ~B+(F™5mëø€d6¡ Ï6ºl¸tZ¸³¸ù¦$RÞ¥‚üŒZÿâl6rN|ŠûhÉVb‚›?5yN“nƒ‘ù¸Èe•_ÛЙhË ‡J9ªJÕ¡Úö‚SdÉ´dÝaÁšû0±Ó^^¯ñÁû†øB0Ö·W5bOuj‡ñOMµÇ1zÏçtë(ÔêÖ‰vsCªh¨)z‡µœ½‰\(ì& 'ЙÆ#Bý|&²_“%À}/ÿ¤pG,\¹rwsó‚÷-ê#¾g ž‘À7Ÿ6Á÷xÄGVŠZ6W[é«"¥ÿØ,1"Hòr’âü]]VÐãBq"÷ãLèizŽ]HÓX?B”DiZ¿v±ĭ~ #­s84ŒΨ S' S!Z¡½üñKº-"a º!¬‚íªO½ö8É æzçÊ4¦Õêõ3~ê·}¡˜ÒG:ÉêXü2›¶ªãCºÐX ¡¯ j ~=vHÄ˧Fa/©“òɸÂ?ƒ3Vú j}ñÃ2E)^8ÑR rü‹E¶å]±8æßóÆ{;wRX·w ýU”4ßE¾Ç¶qš¾ ìc™'±™õ™ê×·ã_…5ŒK澕:í–ؔöë+ +â˼JËH4 ˜¹Dš„v–úæwž"j=Ú½2žg?"L¾ã½KÂbl¹ÑUèŽ_h_¬¸Cžx%é“’x£·cºCF,}˜‰SçìùñÎò1{‰ô¹€´Ó²fª³WSírƒèFGÐñÏObÙ¶¯²úéHez|iÄ~Íj^ÈÞ†x“U«F¸/ xU»’5PÉ‚EË-Ë¿ñ³ÊVà =~Ü­#’Ñi.׳ñíï‡}“ö뽡3XPjý¶ÙuPtá²{ÔY(½îb u¹˜ÝcöKÎûèq&!B÷kvÅÛä—˜ø3¢6H+¥@!÷B…*Á”o„ƒˆÌÄ2#Ö-Fµ¢½ìiìe\MJtÿ@b¸®¤¶¿¼!¥LÔ ›!ZÓ¯í}CÞȩgè “F>®£Û8õäœõª9×7063ìvA.*iš*ñFöaI˜«©ypS £ÕVÐq÷¸Ö!¾›Ht¯?]¦ª€ö€Íû¥é¸Ì`s•í¹km†Ó@¼W¸þ)['Õ¤XUQX ­ünŠ™~ÁØä\t>^ËÍÝÏ .b¿·Ð&üƒË™“ÏT¬ÓÌ9äÄë2Ô!¼â·©€ ¶Å\âðŽÓ?‡ä.aÃ8FÌWêq _V5©Òƒß¿8¡Exˆó}>q¾D§u»ÊÚh¹œóIš5AúH÷$P⌅ƢñÅH 3b·‰dëõ*ˆlè’)w!Ûž©5BëùFŸêçj>=»XËz¡-[ùÑê5}mä52î4??DR=pÍ‘|†º%=˜ÅRç¹Gý:\UÂ]ó“ÒYZ[Ç›æÞÝÁM¼çyÿâùiËUÒx‹~G«c’ýBÐv™ö“/ߥ¬‰b±D‘eÚC»åËÿç¨÷Òô™Ýo6†Çsº{zÜúûEp©Ž¨ãj¼GX›Gr2Åô¼•fúrž¸ ©¥Õf-ŽÂ™tn Šœ•9¸ú…J{‹ÙþD%& yª JŸïÕñ80¦D¾] jôP»Ù¶h4t€íiÚð|Å}u$¶‰ª7¿3\€ÓWe)#«Hˆg YÀöÈYeê{¡hƬ)ÆF®emS†qrŒÍ9íû;Ÿé¨ÍÏ®e¼ ¦ÆìÉŽK…*Úü …ÁÚŽ§&;Ô†WJZÿqm|ÈŸœ½ö®™šÍUGÂÀìqÍ(^n¼âg¿n‚W tì¾ù2Û@S*OO9~—ß©¥‚e 2*/ñ L(Aº§Ð· Š  ñšuldöO#«p®RéEª¦@¼0¶­Ÿge·ØŽeÏÇ­¢ýÀƒßW§ûä²}¯óëµµnÅxy±~uN%‘-îzñÀyñÂrºBÕý³®Ö ‘Wh¨ºh:*Hz¶cº÷« fµ+ ©íÑ¡Äx?®gõÐ)ÿ<ÆïOÚR¤'Hš ÅÑôTÅËä¶Tz¯•<Ó{BH™¼}”ì33sÈ»e¿§j‡Î÷ît7_§òá >Ë…òß&—õ\~A ºå±‚Ãj~ãÍœ£,âG;ÜÏ ¼ ‰ù£­«È‘×!» î»×õÜÑ}0óáÁÅã.Š2ñ `§­—¹–~ƒù\’š–úN™Íé…G8‚ì0Åà­ô/³äê+Øî­¨ÈänÐì˜æz#Íu åÿ„³?9ÐR1òÄH¸V yO©0@BX>dšLÕ¹å ’Í ÌÒC+ðLÏ›býa;aÐ\Pòôâ3Ð%7xÏ–Ëñ„qyÚ9ý³åÖ{Ãœ’õíMßÑ;[H<¬AÚq ¦Fr.¬LQÇA’T™Žè…íðE„"°@á'g¢¯q¡´­­sÄä»c2ùw…z‚³ W*(ÕTéˆ'$f´ˆa^`õì­ÑЪù^—†T¿•žQA»?)š[#_CW_—cWãjÍ¢ËLjJ¼DY$­€ÙæÃY H ÷‹–DÞÅWž aûª2U»c²o9¤¸š2×Íf8% Âôý¼Zæ*¢é…|zGÇâ¹PÙ½²^̳YWÓvVyBu¥$†¹¨¢L*õ¾$CR˜ëê~X̤GrJékPš1ª¢ñºø0XA—ÅN`2|°®€«’qohý¸îÁ%*Æ\Þ…S£Á13Ú®¡éÚvú Rú^0K¬*–ÎÚMY^Lâz¦å*SæugFŒ¼h,nµ`3PÑÏØ—–·‹› ¤¯E9¾rø¢]ŒÁ7GŸ6òÃ,.å·éf•[™“LtÆ3ùi—ÖoI´W4÷ÒÏìCvs .`µÔ„/NoOõ‘qÕQÖFô¦ã\ˆèÂrv‰ZÈØC˜ôÚÙ¾"à|Üù¤º¯ûñHâK&u L ͘k€b¡˜Ý”oXÂj¶®µ4´æ¿Œ4Ð}k°Ê+²aÕ^Ø1bÙ)ÁÃ3ikÚ—%Ð&³­†ÌÂ’äB¿‚þðïè„R•å>tÅ»ÛÝŽy)ûhಿŒ%äõe ›9ž#Ìuø‰DFOØváç¥4éDñx™û²î\foØ-O ¨ì «š6jóÙ=u÷ûMO“ŠÝFÌ®“à.¨¬Y£»™ñõ©Àáæ²ûû1n”f}yÒÁ‹Ï¨}ßwdÅ“d­¬·¹…<‹O£¶ÜÓ>ë‚ûyE^|ÌëHnkþ±å1­Ô¾  •ý<ýMÜb|Ö„Öù7E?íEˆêÛ¨Œ^­,âÄGÙ •_ÒhÈ7çA²­Ä°7-Œ>.?+Ž—.¿˜µ×äs5ô‘aÐú匲a[㯲ûUªØ=—ŽÁÈtyߨF§t»Ã”FküïöÒ)¡Í>Ñ‘ž§ìLâdx?<ºã¥B<ƒº?âÜ6G 499Ó ^ïáPu­rRyeüSi÷b—§Íl" vf‹>ʾ`$æ“¡œeð63qˆâYoh„ÐÉFqèDÛvŠä%µhJ ;+¸Í¹süß…o Ô¿¥£N ŽØ ½9îŒ2z,:‰àv}(†xe¬Ñ2ùµ‚„“³jăæ®ÅgKs"vþè ºŽÉûµBtR­©ØÿÿèïPXñÍ#Iª:°³pÓáÙí³Rv³hh?ßPêŒt/Žb––KÓõÂW¹É2 µð°¶=ÛNhÝ”AyT}@5Çÿ<üå¹>yÑÙ°èEÉl(ÿnÀƒ€ë-œƒZìE—L¼ÝY*TŽK ŒH´g9Pö¨`ó™.VÞÔÊ8q¥L]nÊþ.ðûcÒ3˯ÆRÔ‰ªKÙ¡ˆ˜H/KM0ž(ìÆ{ºB,áî›ÎpÔ֎ߤG òy8 íMŒÏHƒ/&.Røg«ÐÛº†]×”¨àÔÏjÅ}ýC«º¤²ˆÑ”ASïÁ°S-Jc_e¼kðàíTlMÝå±ÿ-ÀÃMÏ:xÖÜI-±0uh¾{p~õ6|)Ë|R·¶ÔpBP P¾Ayà´(€ø:‚†¦,šöÌ!a_X("Yສi Yw$ØÆœ€œ€»âù>¿q¹ì!ö_Axb”\nÐ'vc;ýßsw*… UQ@WˆÈ®‡ã[á«S«O@µýù4ø2 —IÀd«{ð¦W D…ëÁŠPÎr\½Xœ+gÖý¤œC,Ujcç,3¦É3Âx$~mêiFLÉŸ~H\o£¢5èÓ^- ˆØÒxL 3}+Sx'ð7zÁÖ·ä3ÏcƒÆ뿲¶FüÀ 4ëÏD‹«¯ÂœÀ±ñœz26§þtŠüp—!,›ªtA }–!´²hêE7—T\"â(ä𨱖ÞäÉ,ëU~»ÞÍ×måeÕÂßÆ.¯dmBXC³`_^»à»Cg&K\£Ðmðr‘ ;ešÇo\š—Íž‹òæ8ØJ‚m!‚‡¢ €&ü]÷m¡A‡ÝQÚ¶ÒZû§Êo¢MΧ²/Ù51U‚>;´q¸(nƦֵM¿}£ãj B¸u™-…¡f?ÄsA–µk«AkÊ]ô@xš7­·?)ªg˜ÅŠ˜ÔöyºWäRrc9a!:õERØzFëãv„ùy‚în¡ßæ×VB| tH8M%^ƒÕ÷ò}lw&Z’ÁH¶äºº—–?ŸëÜè rY¯9QÎ)10„{ºÇ΃Kˆ13­T_Ü°Mþ !]/æ¯'=—CêèHøÃ#4^#ÁƒÂ ÒözÓ56(D¦óC-K¶û¥ð2Šlu…´úŽ}ûµyp ÂFD‡–¾–IOÐÛÑN‰)r|œ- ­pý¤A¤¤×²MiAÚ¯êU&CÙ* .e—È‚Ž ʵ±]ü¦.(XšŠŒöa„M™ÒÇb8Mô'è™ù´ÕÛu°1ÓIx²³U:ΟŽx㺕Êb ãָݡ|Å9wq÷(ýÜè»Þ“ŸTÍ«X›ª¹q*ßNë˜õ²SAfäX»D+¨7%$N±õΛ.ëšú…‘R¼%`ü‘èéü­k åêm–^u›ËˆYäSý!Îg*„H4Ϩ†N„¥%~ÿ²¯ûÔw!1ßO¯ï. E¾%ÁªêVh4¸ÏȨH‹‘:98ò-§‘ »Éþ1Ik ×4"‹Àû–pyp³ßjM"t<¨ø“–ˆÁ$,ô„Kïó+pmüiÉ©‘Âõ’Êw/æ÷´c—|qŠ*qÆ xÀ…Ï€Së”`B ž— $ÞÏ‚ÙÃ.•§¡zqÄ܈`¡ŸÞ™b£×FN}Âèôô¸ôë’ˆ?3E³i½°â—V¨¥¯a{ŠÇÑmƒéjü¿8gï|YÍ´ózßýI.XÉwÖ»{%BÛ8kg-ÞÞÛÔz¾ö¯©žßB²2\é2UŠÂcgÆþŽùoÎfîk»™ÜÞ-•@APª!Eõ½û;Ûª^ ÅL%7wêéVVçíú¢~åí_ç>ËÐõõ»ÀÃEHÅù …ÁZpŒã¤Q÷ ÅsšJ†äâPè󥌲l9W˜Öðº¥N ³ªæ×Ûù9¯Õ×óÉÊJ#7šsUâüo”Š(àAb¥U~Z§‰"pùöv7ß ‚x¡Àpö@w̃&Qæ²1—åÂY9KêÊÊ€ž¹¹ûO“Ø$¹0`é‘Gl•æŨHˆ©Àü0:Ãq6aŽ÷Ο§Ðj9qƒ3Sò¿ti"°tZRÕÏð£¨Ý^!Ï̪³…óò¯¸nño|Y» Ï´fž"xò!M=ôÿ)ºô="ÅžúIÉÉÌQ%$: ‡.EãO?‹â!£¥a{b×K²ƒL4Ñ`¦#鉫¬oŒ1µ:µÖöÚK€´¨FÉIr½OÞæÞìïß? D^/¨ZZ.AÕI>j™ÄgÜ(!Á%E0G"7Jñ²¼Š¡\@ªPLóMl<`ßéÛôÓŸ±Ó› b¹J­¸z€šM™1ExʬúŽÔÈàþ8]ò|”y5¼Êž ,NùØÓ¼ý¤]¯HÑß×ömoÙQ„Äc¹ù@j¡o¦+r¬Àß ‹ÇGÎÅnrE´G Ë=È™—àöߟ:éšc€L÷Ȩ+'ûdçV'ˆMš’îÒâLOÕ-FÞ/½°ãk tç‰_<^ÛØÝÂ|:×hj(•ý­Sp¶  6Û,¼¥›Û©^zÔ$¿Ïøs£"Ñ9ôÿÇ)š‚V™ì#×j àªeo¿ûüÁj”¼iùí»NÙÊX˜{.‘×¹bD`ySÔŸùË1Žƒ¬Ã;’d'@Ț䵉çbº¿b£ 0<¢ª£ž*ÀB‚9áhN” ®KAæJeF-NüÇ@Éç0ç´äÀœìëi¼õâ ©šO³òJÆÕyð~Ú! ˜5I4+‹Ž¬6= 7ôGhR“Ý)[õg²Fzúê-8a"°ŒV§?&n¹œlO, Þ­%Þ?xÙé:þb5LR‹ñ4R’Y9ƒ²êÈÛ”(JÚæD·–Iw¶—K¤`Ôêynèè ú¯&- P¶á_•„ûn_$SìÉÜÝG@Qóí®¡>±Qô.œGF€]!©àI:4q©{‡Ñ^ŽªL±•¢¤&f<ëj¢¾øŠ–ÌuUÊ7Ý©|u“{kU{2 ©:Õ‡uú  bò*¶ KDþ\ó¿$ÐpåËg\RüíX›¼«lË™yÄ)zm¨–_±\YÍ¢Žì–?è—3Ò¿!ºdh­µ*dã‰à 8?*Ɖ¥É$HÜ›ûÁ·3N­òp2M‰é¤0¬¥[ƈ_Á/Áø¾_J^¤¶n§!Ö©¡AïÑ3¿j?4º9‰b¾Õ5©Ö!ˆé 1l‰TÁУ0`æ%Ò 4Azèî­a¶Is"§’ðñ™RÕ±’Ô[7iˆižêÜŒkÔÛ±F< ëŸ§˜tÄ›RÛ&2U©4BñÚt&ÌÜ(nÁ™Š”_Ȇz§ýTvUžð`Iy(½æ•«¹Þë+sñRžršö9­Õàॢ͆U!üX >™A1MœÃØ–_JìâþÓ= òuß$ÉAÃûÁ’ÞïŽ|#>%¼Øß[¾yÜr±Zݾ ™aQœ (¡˜90%|×xömÁmÝ2K›gj)ÜÁò&»×»kÒª)”¡ö„`Zª—jãêÊglÉvö3HêRì”éõÏÉÕ ÊÊÍÍ2Ôøü¶ü:ÙÄ¥^Þ ¤Dý&ƒ©V´ÙP•ø¶ ‹ThåczUÿÅÓrR2§»þz‹Ñ6£+Kÿ¸DcÓÂÒ±N'ìA9í²Q“j¤= 8Õ¥u³_Ò×üG@ªðm¢"\8^E }í¢ç jžÊc Ó‘Åw¤¾<­'3À6Eé·-Üj00VêM ¸‘4äWWGC/ ®ù$é²&}oÉP1ã¶RBÓ ‹:áMÞÛ½8…ƒPªßɬB¡tÜÐp1x‰ËŸiJª?®' 9ô÷Ì® ¨Ã÷uO~cJ²*œhg°H¬F5øTx]C[‰—aÿ­…¹Jšu 'ê³pûzy(»Q:V¿Ö²7Ìæó °Ÿ"z¾½òC¼/A̓¸Ù¥çjR¯¹%²Ëfëùˆcc'\Z,´(vW“sÉO†µ–rêD4ã©øë$®SZƒ§9@Mó-ŽÍÄYs”f1ÞÌ*BHŒé;‚Ý]\rwлkE2™§Øb£ærÈ!!oÕý뢧;løèäÑƇ¥¨ ÅAœß_á„\Y~eM©Q2>Úìz[ØE+?þ—ÖLÏЉ•nk©e+ü‰ßdà'€a °˜ ”å6È“šä¨Éàñ4‹/“ /H¹©ÃðÓ$>G[Fº˜Á¬aØWáVÆb6ÿfŽ»‡xû‘¤ +-Ù°Ö©ÇÛ/#%pßU tâŸtì7 ©ŸíÒ3 AýýCÄÊ(Á“´LýF̨ žqÕ^ÙjEéó½µ>®f|B™4ûNë`€¹el¡îÃ)HŸd] ŠG៼ Š½oß³‹\‹²š”ˆk}Ïkµ²Ó:œÙÚ¯înFÞ$~²hn±²„&áÎ/mý$èm¯ù AKt.µ†sy…èJ×l« õžÆ_¾ËÏ™f™ã±º-Íÿ»½ªí¯Ç~ôÓíÏg¤ŽÁNRúG‘³HuÑÑEiT n"i[ z•Î±ºN»hSÎãx¬ö¦!ƒ‹²Ûû²ÆÕ€ä9Ó§ÕZî™C\¼A¶`è‹à’U¸Šÿ¿ÄX÷/ NI>Ä–ÌûGĪçwÔ麔ëhIÞƒNlgã6-±Ð endstream endobj 3760 0 obj << /Length1 1647 /Length2 16369 /Length3 0 /Length 17230 /Filter /FlateDecode >> stream xÚ¬¶c”$\³%\¶íʲm³Ë¶eÛê²ÑeÛvu™]¶ºl›]œ~ÞwîÜY÷ûæÏÌý‘¹òÄŽØqvœXIA¢¤Ê bæ`”p°we`adæ(XÙ™¸¹¨8Ø)8ðÈ1¨-ܤ]m18 1g ±«•ƒ½¸±+  4ˆM¬¬8 €˜ƒ£—³•…¥+€Z]E“†ŽŽþ?-ÿ¸L¼þùébea üûÃhëàh´wýKñ¨ \-s+[ @LQI[ZA@-© Úÿ6¡äfbke ³2Ú»iæÎÛ¦öfVÿ´æÂø—KÄ` pqšZý zšÿèŽ@g;+—¿¿V. gc{׿wàê°²7µu3û§€¿vs‡äèìð×Ãî/ö—LÉÁÅÕÅÔÙÊÑð7«’¸Ä¿ëtµ4vý'·‹Õ_à`þ×ÓÌÁÔퟖþ…ý¥ù‹º[Ù»\ž®ÿä2̬\m½þæþKæèlõ¯2Ü\¬ì-þ³z€3ÐÂØÙÌèâò—æ/÷?·óŸ}þ·îm½þíð/¯ÿUƒ•« ÐÖœŽ…õoNS׿¹-¬ìá˜þ™i{s ó¿ífnŽÿ¹ÿuAÔÿÌ Íß"ŒÍìm½f@s8&׿)Ôÿw*3þ÷‰üß ñ‹Àÿ-òþ¿‰û_5úßñÿë{þ¯Ôn¶¶ Ævàß{ðwÑÛþî€àŸeckì øgáX™þBí¬l½þOÁÿÕ[øïªÿ'ç…ÿBÄÞâ¯B ,Œÿ6[¹HXyÍ”¬\M-æƶ/ï_vu{3 ³­•=ð¯Èÿºß¿AÌÌÿS³´2µ±ÿG ŽC@{³ÿÚÃ_ÝþÕ“ºº¶Š˜ÝÿaÛþËYéïT¸ªy9ÿ3“¦¼ƒÙÿ:üC%*êà ða`áä0°r1ÿ}ŒŸ#+»ßÿOÚ±üçYÞØÕÙÊ ËÌÈÌÌøûýŸÿ<éÿšoö¦fÿÌ‘ª«±½ÙßÑû_†`S7gç¿Šÿküíü?Îÿz@ 'ÐnmÙÁ”/Ä:=+õ;odR\w |$Ô±¬I­¸0°Ö¡7 =b‡§Êè½.”±yš÷³ÃkéÌñã@†öðW–-Uo*ðª€ÀŒ¦¿u“ò'Ýa0“AbƹfŒÏõ¢Ü6„'³ÆáŠAé;áôO6g˜ëgš@2÷Â@ ò'G$Ó´ÆxÌ.”f´ú¢³sÊä“ç'ª¡±Ñ‘áÞ[Èþ|ºÜxX >clÿ”3’®^FÎM¦Ÿ¯î\nðˆ>èndAö¤éb ÞóX©–ÝŸÖMsiZ³lfö¾y° „„¾grùIÔ“Å™†ÝÝ  ð="3¤lÑɨgv»k>6­¦"úJ0Q³e^H{Þçkk±[¶ñIü¦VY'Ì‚W}uSn= ÀÃH*ÈYq)˜í%®k”ío*±ÿF•xò–U8¶åq"Uê+?ª6ÆjBæ˜÷zJútá,ªR«jÎ$xÖ°^È\Ze½sçýÞhÉ%å?­‚у^€>ïg0$] ê;zËôÜÆÒZ[(nrß{,¶ÕS‘û›s6´†ì*9—ŸVø-EùáðB3.ö¦¶te  —èó­~öA®2C°ôûL¬]Фª »ifåû¼ZŒ\%­|n‚e¤2¢¿Ñ¯Nx©ŽE0ÒkP¼â_Ñ%Xºm8˜ìÛpÚ>S„â—Å?ya ñëqzMýM¤ÎCø5u7œ@M0vsÀá£rkË#H¯ÒV;¿º™TxR‰p²°ø9 ~Š€Dœêè΃Ñ-µœHt?ôSF©•EOÛŠõ×öÁø=8®0JzÝž” yÉ{ òà-R¿W*M ^Ï µ¨®¾kkE'Q« û½s¦§K(äW„¸£;dü‹om‘ò©bÏ ˆéíjšëÅz=‰[0ñäÉ{ y`cžóõºBxx+˜a눬n­ÀíÆäÑ•ŸêäV=5²^5øn‡*urX \`~¿ÓM ˆoš;³×EN’NAÅí„ `¡Æ„Ìò¼,›¿æGTð¬H꯸Éqr\nwaù:(¨3£÷ª]AšÜа§³, Ãê-¯v—™yÒý«”}}í"Á§$TïkUßX·ªhÈ ÜNCºtûÓ<Šîã?-k\ØG„1ÞÑÍ„¶§AdgH(°h.aó$Å¡?®«ú ÇíÅlîüFj¸ü¾\š0@@…Á¸¢PR\mØë0 ]™b¼§@]M„2éE¶%MŒ½íjÔ%Œ¬cUÚ¿a6 ’^Æ嬱Ã[Šgƒ‰“’liNp†íC|ôFî!ÚMäbƒß×ë|¯Y;Bzbƒ$¿æ§åÕ'çª uåéÅÊÛ¸€ í8èã¹äc2™üá3GuÅÇÑCXÜ0–ÀžÕ#î'"¨?Õ¼ml@ß*8„Ù”1 –aÓ:ø1¹Y4+Ç4ÚX ós¾7.¾ŽbÏÎ"õ}š 59ÖH§òƒ¢ ]6ÉÕ¢ˆPÍ=w3‘[ì:ż{@Zç¥÷4ó°ˆÑ$˜Ìûêêgç5ð†CUMÙ`J:K9¼8ÌÛÄÎ~ jÏ.ÿ…­A¥`žöLÈíö+AOÎÛY+’ZÞ„õpÛf¨æº|) ìǼ»Êu„–ÑM*Žýz°I­|ª tºÍ6™­}èg˜q±ñúÁF˜Gj7¥§ÀåÜ Çï±s3`ÕÕu@ñõdÇôc?}•2L.5ÞD3‰®^å知Ew›üó”ò©mÙ 7ÿë¯W÷VáwÈùìuE¾tŠ2"³Èô÷šcˆ¸Sg‹'tî¸{†¤±£× Ãòñw 9[ÖÌ=…}´ÎÏ[=mšHdÓ*ûýçÈÛÈ7^×3Úþ¶T¹Œ¡Sl\fül¾tÅÆrº^5žIÊBµ:Œ½Þ•¿)F“k¸éžE³³¬a=F¯teg)‘Mn}EÇ×wâó#gˆUöEô“É BÙB!ÔÔG€? ãê›­¶B~°háGaÎw°„Ú’£²mÄ ¶½‚aÞu:ŠÌYúuåhs•ð -~ÖÑh<|Mùç‰VQ؇¯ŒkÎZE4Ü="¾(ƒÜ).ï~Ö?½T ¿:­e°ãá^eˆ(„\ù9fÚpªy¸í·Ším—fÚà,ÕZ.‘:Ô±5¦ã?ŒDÔ³lüŒÙ¶Ô&Eö"*«Ìm¤¦{¼’û¤Éòئ ¤= •‹4êXG|J†/)¦÷É#âL¸JÓ‘ ,)Òª4?_Z¢O³pTÝ›Ïjš>Ú%åQÁWaV‚¹ŸløE“Ý7L†íRòž½“]`ÙÈÒaiö[³"¯0©×Vf¿ÙÄ6; PS ÷“SÄhÇÊÏZ›3¡rÜ’y5   '¸É•,KâÇÒSÀfå=Á—ûehû…ê_—ïŠpD±_Ð5Rl™æ°è>R ¥vÆ»‚(¯3â'íB#n+&öA ëaS~ÝîÜ•cýmc'7CV±H<ÔÇ.Æy&÷(¼ü{† ôAÆ,ܼçRó!.ðÛè T‘‚Æ—™‚ªXå}Ißçk/èC‰3‹‰iÝlƒ·î´6¼‚¦ âv{Òs„4õçóÛ±ú>óÖµ^T÷Ø«N'ɇ~Ñé;X´\.°¹*“Ûþ§»Ö~›U!” 2 ÷!û“ç±ådyû«£ÏàŒKÌ8>ÂW\¶QD%¡•yi˜nj¨m¿þr¶ãÔUõãÎØ ÒÈ­Mg•Ï·Xt¹æàæø¹CªÝwA¿ãnóƒÇVnæ|Áü1—Î¥lWd¨!m ï|w ›A…jNºßee¤ˆá%sÅûj²È};úthæ1¬çTï©Fýô_×gèhÐÍ õ=šé›$ °XÀ¶µ^ËnrëYh#ÝH]¡$Ϲ (תi‡½ EèM5ï«Kµ"Vò „’=»]Í£^&4+n”7XÉ/÷Ý.u£»Š?”%¡úâ oÄ&S¶Ù~?¸MAh–^§…»Ÿ½žÀžï'o·Ø9åJ)¾dÜÛrÊ°{!0ØɉÖÙ¬¨Å5¯Â·à˜ ®¤ø®#Í“þhж†mË .!1ŽŸc̃i£‡óé}ßÙ[E}œÏ{þ’»êœ³ ßíö5¤É)S(‡ËºáÏÜd³…ìô%´é­BCxVú,P–©”S¸}Ú^h´1*©µ¬ æ_‚«¥¢×È÷KM$wv‚ç]0*×dO1ÄÉ31þ âßy§.)_ú„.B_$Nˆü`B×i¼ L+F)á!ŠÐ.Ò£ÿ¯Mã©H´­6mQ’<ÏnµåŒ5PèǃǦÇû̧˜ x(þ”‘†_5tD_éGêÀ0A™“‹dÑ7âméGTbX°ê¦‰a‚ÁlÁY‡Oû¶ã•Øxy{{-0du.óö· .kYâx:œ|؈õg9L¬‘¸ÂO+éØ(—Çå2¤Ô§¦.c›ô×>|,òÕ¢£j¬YîÀëëYÂ=hЖÐ5ÌèàöYh1©Í9pQçÌ xO&¢ YWˆMÍã¿Å^ñµUa,'MHÄ0ÏÔv¢nB †dhAÔ%,fê^Š±ç%îb®Ô ÆDáP%5+_½™£SŽ>`êcž9lYCgú%ôRvtçžZÁ«ùii…¯E-\óº 9ë137|ž‚Î&‰Çëš]v·õ“Ë–6ãµ$¨ª;–z~QØ» \ c¹Úž 9 £Ž‘)P«Ú9,‚4. }ØfÇ6쪟¼sÏ4I(Ìvnq1@ëÆ`ØÛ–KÞY¥Ð?…lºUAÑ„-Š)iš*“p†º¢`éþlõ€‘Bm÷ üצž‡Ê‚ŒÕ¬Š]û<·t4bï\¹!ÿLx‚&ìj“6[©m¶ð®¸%FvO¼ 4fYT$2£—óž”8“xV;!·%‡èŽS+ýÅr¢)V.R…C¢¦Ý‚nAŽï×ðGpÙÎ/*i.dúß‚ãô¸Yœ*ýÐ@´®Ti X!–Ó5lB¦©ÂÂx:÷O$2ÖzÊQ­Âlº–Ó§bSV$zÌ‘Æ'Ž¯FòþëVÆcç³çä÷—^Hä{Iƒ«¼äYáÛ/WˆjÎ9ÂÍù*Á»ñ' c? žÚ}poÓ?GøÖz0yØŸÉ·?gñ~«M*À÷±:ùéx*Ø/aˆú¡W&kAQÿ½ éÐ}”Ó{#+ œ¿·ÝRmë ëó™]1§¹¤4½„•Œ`ŽÆ\5ÁNkÿrNò)©ù=bø!ŠŸSÜK®`ÓòŠ ;¹r–ÿ·¶çÓÙ]%¹“áÝf#pHçµâK_ìs$.Wà¶:ðåkF6vmÚÙ¿gº‘qß2¿Ðs‡Ò#x“­MÚ)%öÇ$‰™ˆñqò ÞDf~è®Eé}ßIæp›.'Ö>×J{º·çÆò°¤Å;ÆwŸ—®ã ø,$M{}ž6›¦7°¡Dá9]yã^ÐN-Ñ q1Š=»Y/[’Æả1#¥ã¬$R58ûqJ$ã©pý7Z €ÜD~*õéÔ0Ëwxîî±á¹k?þ“™m*Â5§Ö™åòÍ…ƒžëH~Ù' ’ܼ%ì}ŽM 'ïÝ–c7ýÂ'£šž¦zõ'¯s…ÛÊSÔ[´¹à|iB;Õ´§8poßum Ö¦™SÏAòÓe¡§EÉ°Úû–þ)ÔГöIkà¼Ñ6îLDQ~Ù"J[ñ@ä~Iß<ª$þnŒK¾5É;{|ÏgœRFR°Ø¦K›—SuÌd"³Žò5˜øìšê.7¿.e`åØ¥ŽZNMÏ8ÖÎÌ¡I[jYå)vÀs7õ °ªæþfÈh´h~ñ‡L+vEl:îµë@ž~ÏpãÑ¡˜_Š‰­ÏPὌGÅÛi–tp†‘¿³æ²JÿœVéÚØÃÌÜн}²8ˆ#Fz6EÖžø15]ªÜéVŒþžötˆâ]——jßA‰êx ñ,Æ›®ñžubØ^_\Ÿ«Ñø{ºµ’as,bŽnñ,+YˆZ!Â]Ø€ÌRœ#‰&ðzš7y¢þÝõ2á´éíöªè‰W”¿ %ª?L.5vpã¶v¶FØM¹ê‘3ùÏW–Öÿ¢•”^H J!ô6¥¡Þ³qói1ð¢y"ÔzÛHó­kôHn#«ÖÇ`n;9 f½‚¿GOÜ(W±ºŽîz=4ÎänTÄ 'ïY”iŒ˜æFVÖ2g¼Ç Ñ,€SvseCwÏý»bó°–kƾgjÝÔ0k~'è¹3™Ó/°Psé îœ øG°Ôpõ{ÍYymcü­¶.qñô¾ÆëqoìëìâySk5@³blÔo]Ó‰§FܦHSÜŸq!UB“:×\tÇ¥&@G–û,E÷Ö ïGK¥˜x(í=\e#ÊT½ÊjFŽæÙW‹ªh ËßJÊ7ò?Eá¢À{ Ö'4?&L³·â¥K7^Ggè%YïߪÅrV÷Fd(*¿¸“%z‚Ú†*'†[ÄëÓ¯…Ý–:}«8ñ2Ü'ÿõ]i+j?@«éêgçÀa! ë8µ©ñÚ+R`œ+¢ºÀìëÈNnÕĽïå!(ºc’çÇo”ßzñÏñ-¹ö;qÓ®ê—gƈȭ™Z L"M™÷—YE²B`v/’XˆÖð ¸úF”+Yg~ÞékÓ®ƒöÚÍQŸæ›hÁçÍï:$\@h£c[Æ°þ\ý|Û‹;/ÃH7æˆò_Çñ©*ÞÁíA#ª¡Ìk@ÔÔõ©ÁÏ6êâ¥×zoü^Áøe6¾½Í1CµÝ^Ï7ƒ¸pÊÁYŠúõl}¡láÊ®$Œ'†™™uJ0¯ð<ÝGã:—^)P iÁæ@M½öDÇ}v†ßl|÷”ßxAféÐbM›º¡ê±wj3öt;µx»²*å’tm?XPˆ¶k¹‰pòîpRùT±â° ÂÕ5›L:+õ*_€¾Øäü,õ]÷¼Œ—pšæ¦‡ýT»¡ñر s{-)ù¾©Dj„!,‘à¯GÞ‹ƒÍAÒ>\¹ø4μ–ÚÇ Ãuá÷8Ý ¦È›uMþpGtÜÿÌEH¸æÎ…þOc#_ÿÄï…'•Ö?بèË3ëR\-ýÜ7äð~í%»©t+m¨Š:ÑŸÉù[—ž]oˆ¯²fY´–ë~ÙСÍi_oÓÄ;[ïД½êHWlM:˜\&SÍÇ2R€Tt¦¤ùg~ÙßZ©\‹c>-Y{âl!à4¶œæHû@Yƒr[±ým°ª¡vÏ©4K¶L’‹$_9°fÑ GD¼ÙèA½ ö&ÉïÀ‘×ﶥÁÊoFvñëvWuDé‹i ¾‹Avw…Àé{5œð?ÖúUuD!¿Í”ô'ôš(ˆ¤ }‡‚oÞ«#jüþ>ÂÇÖRS6j7„Ÿ-—D-73™ú^¢ñƒr•ùÖ!ŒA™$!¶crŠQžw¼ "ÒƒKEäͪùaý7_dnH¦s:,ÝG?˜\Ƭb¬íÑ—Z6vÆ—ÁPo¬“óýÏçm™­í1¥XÈŸÒõŽë"ã?ãfô¡G‹#KgÌ$â¨å¤vÒsÈŸeØ7ÚMuÝ_P—¨‡“N¬‹Þa“QßhLûÑÅ*sfwLiz{éJ9Ì%™€ô¶à/jž,Âhãí+â(²àuÓË ®­- £q%‚>óJ,M‹”Q¦"ï‘Ôcbc΋þoy [Im˜ÙuÑÚH Ó켑Â#±ýÙ¸£ZÕ •÷èµÃN‡Ðz/°Ê³Ü‡î’è»é9߈RÿH¬:šC¶Æ»óë„˵u¡`f³ÚÓ¨l^´áwÚ~rÑ#òQkÓ,[`Nmuðˆ)»±u¨žƒƒ7ØCˆ~ÒÄY® ă <ÀèÎI¼w"›õÿÁÆg–Qý„˜¸Wnr#Ž>´LAFj†cbŠÈú^cÙ¯5!³F ‚ŒqºF{Hó3šÐ'Û5ÜøñG6‚ʱ(ºBõ½7 Ÿç)›EAÐòV€M”ö nVa{A\…-Ÿ»€*Å°û—¿:C²“ hC¯ Š¾Y=™Ô2iÒ”é-¬×GÎN>¶dR5NJãx:0e-ÄZë…YYm –çÄÌ”׳(’§³ EpüdZ”4;›ÓÔó‘”oÓ®~Ò&Ëã…à§H>sç¥ÐŠMÐå"c‚$#UëÛÁ·u”âÂiG™SßdhÜb›Ç»§Zw¤)¶ø°5¢î ؆K±˜ïG»pÓ©VþׄÁB­*÷“Ó–Ò’¦R/]¡  ë4¯H)øN:”$Öú3ŒÍ[d²ÌàÎaEV&¡ì¤‰†€ã–{¨Ã8!xº1048»hT^[ÖZì!mÔ7ò§Õ¤þ-Ë×-qKÂGívè ¼¿/WÑ,ÚX½ŠnJlëÍ3øX@±°ø F~‹ê—6]ÂÒžFàïâ´½*ÅÉ>ÿ'ß踰6H²@ï'‡³5V~ ”üË.m,­Ð$¤UD¹’š×ë‹õ l̶BF¨ùÈ¥ÊUÌÖ≩NµÍá–³° ó4Ü]CHs3Í+•>( îì sÚãÅ*î£ì–ˆM Á¬·lŸßB.¸Máà÷´Àî”^]Âh'ÿ;•.%8ÖÍ¡d"bšGY.°¹+#Éz8¶Áµ ³™¡{",[c4ûXµü F”Z-pÒÍNóŽ?½õf¬Å~‡ŸŒ\ å½ŽE}™ä=Eœa²ÇT®B<ÁÉS¶%Mv“>ã&ÉÐ'G×®«a$=†,¢‡˜š¾«¹Ýd¹?+v ‰Yœhc–‰Çÿ$ÞîÔÒöÐà{äòØ+Úôd´¨}þ0VÃò–ú¦Ãà®$w`ŽŽãLUøú+C¢ó²¨Z+¡u¿sc'²ËKzƒñÇ®É €âM™>cFÓ\Âߺ¿þÖ¢ø ðšî÷5´ÒBŽ¡t/ µdSÀD6r)•LŸÏ˜àÎàÕäÍß4dbB:ôÇ\,bÇÔÉ\,CÎ!fÉ  =µ5~ƒ€\"kg7w¥˜”ª‚Æ¥çó9[*»ü¨íó]P/'õ8Ö¤ šßýÁíÞ¾{Ûlb©«jÞ±^ÓZ)´|úN¶o§ž«X{5ˆ@éM¶a5^ht)³Æ7¦ªPD¬ÂøwXoÜz«=Z{Oñ Â:æK•‘¢Ê-Œû3ÐJó,Ùx ¹³ DÑ€ºñÓÕˆ¾}q°®ÎYMn5ñh.‘ÀÜÓÌølÁq[™wÿã ?þ1$j'¬ÓkÜ—úR¦qfkký‚2ÀÇL¹,OX¤óNõ³Ùî8Baø÷­¦øÁÃêð¸À¼$g‹ú­í6‡Á^ ˜•þ †½šw:ŸòœN–˜`z'}„„U-b½$¬›ÜÏ.r~×í(àæ(Ó —^âÛ¸–ˆ»³ÖOH:UÁ¢;¬Pt覩é¸chP¿7>ølÁÛß<,¦°WÆò¸-<˜elô&ÚÉ!‘Üž°Ú¶/о4*÷ú¯î«ÝÔ<^EØ&Á‡w äÒùö`žsî.ü¢>œ_¦·Dv#ЯeFŸZn’é¤àrú=ã€AïÐ _Å– ÌÚ¾{øf!ò?\kœ¬­SÄ“òp™œ“ ßPèÕ>IaÐi¼®Ã…ÿÞʵ¿‡šnŸÚ–©,2`§í”êÎ\Íry;kÙ—OÖº' YZT£'a'o6lÀúRõ6·ñ¤¼þÜÛ‹´ §ÀégXz‘¦(omŒ“!!KAMCç¥|·ª¿dŽ§.:.ÛP8š·4ûZ€’_¶œÅš’ü5V<ÖI)E3Ñʃ…JånÝ 2ª¿_tŒhé¤ø‰uô#þ£‚9hírðèž¡ûU¦ +llï–=š)IŠ {º¡RŽ;‘+ÕOÛ-§‹WFc×aa†ôÝfà¤ùÁéŸã6ó®¨Á¡ç ô7«“FA&M&¶<)PoïôÆP&=“¥¬_Õç"¯¢YΤbJcúî¯IÏ…VRðVŠ”1ecÏ Lìm?ØzØ‹¾•CâH!æÛuO zA’Ú¯ ã )î\ö­¦ˆ(­ ÒT‘™‚Ѩ=üºˆ¥ø5Gg:Æ®–G™0Y–Ft`2ಘǻmØ…ÏR}ਠÜkÐh3õõ4lÁ¤’°êÍ­¾ÓgZ>|ŸšÌ,k–\%5ä;o`Û؆Œ7”Ù5‰æ^oç×ÜÔCÑ!W‘¨@[¶;1ý¥•4O‹a<Ú‘Rœ©qþž¯;ýiîϦ'ÖÐúž´î™!•Rø©ÿ­pÉw0j¥WòWùq°ȧÆ“÷ØíW{q˜”P}N9å“G¯õ$9Jiè„kùGÜáÈ€ðÂÿùni¢nˆé`&y@ÍÊpüêü+ÿÄól æ £—ðX³Ù¶çúì¢âÀ rKkÔ?.¹›r:V‘°i¿Èù…ežw‘Ý'¿ª~« 0q´ê`o ‚€’NÔÇ_×Ú„ñè…î8ÑBU—3Ý÷Õ8=ëéaQÛ1Š<ùOŒ)æ.¯âb[(õýÆíi¸fñeööÞ¿,÷‰!wˆÌo/w-•Iî)骟©’92.S‹ zQüΖ õ`™òÍá™IU˜¾è^[þ#Iƒäy“ä`+à£iµBàžëB³áØÒlòŠ²‘–DTù zéÞ5±þ¬ ¨Î®¡¿€>ù!°%Å![*Ty£”tCÏæ´zh+W³D×Ù𠦤»Î刵GåÌöÊ U}â+]çΞ>ÞƒŠmþû q]4ÀÙƒ¤ /¤ŸöîûQ¹›Â Õ eywÜ-ùÔò*ëÍœWÐv°}ªƒ l0˜ŽÐå·õ´éL›JœH$áX6±=­40 ¶Þ¥è‚9¬®< ªâ&kz°zËØÞ±²Õż‰ó\¯„c¿ŽÈ^ q«ªïixW÷»‰é'ùòð¥*&þ«KìIr"[Œ2ÀÔ6ºeYØlÈÎïTÑÎx~ 0i?d˜ÝhÍ¿—xü6‡UZ·ËpÅ#•vEý÷ŸÜyèýN¿8ÖˆÚ»Ìó ÆûäVí»_m¯eÖJjqaSNÀµ£ýo¸ÄF²k¸ˆP—3Éɇ‚Ýi<Žï8ø¯åx L7Õc°£>aìã 0zxõìHÖ>¶¸EÅ£=èwœY¡?;S âöìĸºíÄÎDÎC÷:a¡¼£QZ’ÛPÄŒÎزa`MŒöõ7Ï¢îÛ©“ærózÍ–>ÞÛ·myž™ÎÒ5ç:1¤©XŽ¹êw:“ÔñÔ½8µßq⥊¿·ž¼VEVwÐ’›ºÊ¡ŽPæ‡ ï˜.dI˜: <ÚðÄô¦¾ñ‡4.Ê®ä½=’îLn2«åuä¬bÚn…kªÌeö`Ä+Ip½S”Ò½94/Î@å²Â¥Ê6óÈû¡éœ¿Ä¥c§–æü8 ;ë¶åhîxùPïLTkóà èÒ•\Ÿ5^3ƒŒ¾ò…iö„Áƒ¹"8´¾Ãygϸ…éÄ!ø64„†ñ¸ƒ×º6e"em_—Q)"è†FߨèèVÕÑÒÄíT¸·}“# zÓí Lö¼aŸ ðZ[ôE¬•µöå$¡ã€[çÿ™|¥läõ' À$Û•š2¿ŒþjK‚:A¦ iÆÀ¥;š¡€ÊŒÌµ‚bb5Ue‹ £¶BË ¥äêÄ›Û:©¤"F퀖KŽÉ~Æhã U}€©ïˆñ/ë^¶¹Šv5rˆ,W¢ñ Qúb‰T¾,¡Nu«Þ-4R•iôþ X…+Ð-ûæ[t²)Ez£õ©²–ÊÞ”¢"¼i%oáw =úðɦ³½²xx^üaƒŒÒ¡À?~õ¬ Æ·z÷¹¬”=»÷¨qþÛCç“_ªC`+5¼KÚ‡w—L;¹pŠ«ƒSxÀâ¤r_mc­8M5°¨Çc®XãÏ¡’*]žÐš“ •ú½°*‘ a§^¿æ¹JLžû|+µHƒ%×IË“+K‹Æ_Ù›^ÂëB Ù«N_ó}™'ÄSÄÃÄ@xýzâkøíéÓwfXÔ¤riæuøŒ´/ Y@T?¿³ˆá_P·!ø Ôáº/2ïP °²Û\‚ì}0GÊY ç+‚›ÎF—,«±°xe:4h*œÊáÎ΢o¡Ä³äG¯ï&+ãÖZ§š7ðfÌçéH Á`m•6~P¿÷eVäíj<³ÜÉޡļ +² 2yä“ Ô‹Ñ<÷`må{‚g «l^š<‡¬ðâr—VáVí,|†ZçüŽì³T’YqN–“lž~½v—ã ‰°ØÓeÉ´ÒXÄ(ó¿l¨kòJ•ëdâjòƒʦ»¯^œŒ·¤Û G§Jãú&¬U˜°Š@ûœ¸W­Ñ´Ìo–áßß²Z(Ȧ…<¢„ycæ¿* ã‘x@˜Ès13õ„ѺpûQ¸ttž•š*0XX/¨ã,º4·žöÏÉ^k½Ì—ØÝòLY©"Iη(M±Ñ<ä‡Öˆw¬3IùÒ™ævþäÒ,1Ñ29Ö{sÖ¹4v–’“Eÿ eݱuêïÎH#v°XeùFÊ¢5våWp'$š¤TõFîB­­¿ÒvÕ¨üDÂÑäÅØ䇸=VAà$‚^õñéG¯;Ù`ÀÐex˜#ýWEïüŒÓ.b&ƒRASŽ¶Ã .ô©íŠ}@ö)ÃyÚBÁ,¬\d»¥TŠÓ©ÚA5ÔM‘s>qÖ¸æ±ÔX#½Zoß6beTºÊ5aí£°$·õ·Ãó1/èè4‘…´S&)D2¸Ä{³[B4xrûƒ!RÛö9ve§äNÏíàoTî¡„˜%.a.ôíj“…™žònm†F[ ä¬”»i )ÄîÔLÚKû5#¤Ü"n1÷K™ÆºÏ¿/ ó(¤*ˆT0Ì¥–œ{P!tzåáiÁ= ¸më®CBáRf…ÌK}?‹›d$pƹäF>š¥æÖ^/’õŸ³o¬¨äÏõè 1-(¾ó{ùUUcì†ÓGñ^™ÚçWQÚY¤à y),‡Ö7£z ,žÈ¼S7Ž·W¾Êl½²Æ Î0£Ã)ÿ&°û9¾²@A¡²™6"ÏÄ“_År‘ºÈ~¬9•‰×Pˆ¬§‡PWßÌYñ¯\lNÌô¼Rhrâªõr¨ØD÷0Vç–Çâ+ƒŒ ¯›&½m@’´ÔNi—3uyÿÍ?3Å:m¶Oâ2¢y«¿7?g `m|¹Ÿ¤²ÿº2[ã³TÂr«ÕVŒg¹èrwóÎWå{½M³up™P—€+_×hºÄ£Ùrâe_ù ÞxiŒ cÄ…Š*øGn¿#p¼we¨b™ÝwaØaù«AëµÓÃÅ™Yy¡åȇÿ Ûƒ7½‰Bo,V¼Óa°‘‰“@—:ÓDàÓ-¯Üq—œ¾?~ð_ñF=Uå!>bFîf¡®ÍÉ‹®ÊªmUP'ýÚ±yP¹õ®1ú÷†žý«[ âÚ{û"ߺC3Y— ™Àböû纛‚y™°€&º ²)DBW 4ghRBdýnŽß询/Ò®sœÇæj{ѾcT9¿œ'æJN«åEÊÀ‘áëe(‰L—µÞuh¬ãä–Ûz?ì_'ÌQv–8ë¼t3 %gÛ¿ä™e°>¿ç„]‚ѧ§jKª‚6õÛX^r«9ãê åFSz÷¯ÿø3*o„ÁP^ŠLÇ– #åþ¼ùõ-UÇþÇ×—‰õý7^l¬a©˜bþ'ªü¡f¶ï©.€âî_6Áš'ë§D>hyMîHo};žNczÜÀÄÞXŠ ¦·õ‹6Àˆ'¦ø9m°6"VÜÐZÖäy—ÏWµÚö¼8Âð)Ë]MPõ_z-‹hWááA‘ÇH×ÁT;ÃÈ4§÷M£Îƒp®ˆ²Ç3´Zš#NÀÔ !0Æ$AéÛVÀ¹þp=ŸbÑ)%k½hMýÉí«ÁR @<ô;qa=Üc“)EÑî‘ŽUƒÔÛìLQ=ö+ïÍÞ}P»Ïñ^l©…ȧRzÕqÔ¡ U§¿€ÚI¦4ÅÐ’YíçV™¾MT¢_Dϥοä¬úSÄrhkýû%Cân5¯ÆGŠ”†h`ÕNˆKâÈmTw#Vå^Ãú# 8ôlùkÕ#”_ogçŒKHÒˆëG‚8†?ðØì5g]·’©kо™ Ûz¤dŠü‡ —GlÕ]gá»ü ÁœtÕÇ 0ÅeÙ8‡-Jñ³õto©¸`d7VwK­á9’™‰c¹m¥÷@gèøë]€1-rš°ŽìX1ϧ5.¼À€$ [c"ï×!­B§ïE9£ŠÀdÇ$LòU›Õ¥£Í6¯ì]ÿ²š æâ3wv(QŽü‰ÞÏï¦"„sMÄäª`›±2å~Íê—îèâÜ/)’#—m@ì :#ŒÄžc˜³!n kÄ‚e^±Æ—?m¤à@ Ì…Æ9-!ËÔ)†þèçÑA²Ë5E;˜Ôbئޓ'¢SùlôvÇôñü¯Ùæ{Š×¤ É7b_‘™½Á.K‚Á²Ö¥Ž ˜k:døb|%OÊsÛ\’¬LBú#ç×’åƒú`¬}ôˆ¶á·¤‹wlÒ*¦ßÈ>]Ka¦ºudJ«„“ð[cz¶XØÃlTDT†öoÖXäíºÊ’4žÛçM#‹w.æŠO:¦™‘ŠùþPϲ‘ß#?XHù$Œ.œ¶¼2²@ð+)nåÙ}gXQ^ã‡>¾õŸ®@šQû<'×…×wÅ8¾exë_`Å‹Žªþtº{(‰f ¸$þ=7ÜÊ ™N‰;¦|í½·„e²P«ôÓÚïÎiÌG‡WÁ8Ú~>uzÒ ŽS‡?;´[Ѹ4Ât‘r|wέ/7biŸ#¾œC]3€ª(y‰GEQÃ&Fð‚:/8Hjz}iÁ½„fð®pz§7wÈ/Ò“ 5Ç­)þ\oacÃ{dĶ5B¾¨0×ÕßØ@Žp£(,ÿþPʘÁ€'êûù‡¨tîa–õÑL9¡;~ÿÐWb!¸¢{ÑÎ*ä6°ýäÅí‚ßs"˜Í]RTfã̓\Õ–O¾¬‡’æ3Ñ´JO½vêý¢^s\2xŸO¾Ñ‚uºBÆ®‚o¯yûÏ ŒÚÅ«‡;§\ÕŒ¨µ]ÄFŒAßK¥á÷*ú¹ßZÐÊÃ4 ¨8ž ÷uÈžOÚvhU×ÖŠ(‘ý˜‘µ#¹eÌ E°'•ý<¬Öó‰†'¶,Ý·v}ð0K84°êwÿ†#´ø¦ÆD çÐw»8GŸ{÷Ádjk)t±[:@ü ð‡ÆÄ—Ü`,:ˆ¿´h]A3pa`1¦MµmzNVþ X2JËØul¥`ßÉ/äæ» ¨®t!Ämö÷eÚïžçÑŽuÁ <Ó~pòuáEÙ$uª·ÈìÂ~=H£ªÖ8Òc|-€+ùî|“¥&ˆÄ ¦1D¿jÚ?Ma|‹E²c© -c•‰Û»ÿÇÜI ºøôwi ô!qå°ýuRkZžº:;±†fÝ—")žëÙÓ”_°AíkæÛ9â)0;É1ìÏäƒÏÿ¨ªtCNÔܱnêß¿ÉÅD(Œ"jâßß^m@ª¨Ü)`L;ånK²¹s´T}:LÈ=ÉYï–“¼ÄëeÀ!¢žèä¸G”M¨Nf—¦ T1©-¸‰]¾Ý^jjÝ.Ë\‰Ë6´&^R3èfÉßûÛGùUä¾Qn¼‚?ã(û7¨ˆLɽdåÄ6»_åÔ"„t8\4¿Ow¥v ˆ;ßñ¢`OˆOhˆ4l2½SÊôóÖlÌn?3Šƒw˜W˜”×Éu¹kõ9’D…?‹!cˆßeÚÒñ!¿Pu1õ6ÆïœþAvÖ|4äV Æ7~ÓØ“¼ñ…çÂýÙË þšè<âÒ¿LÀÀJÄF¿íºŠîÂ8Ù{*E-XÇâ ‰‹ÃäY7¦URüðÒÉ{¸l²9ÚI{’=cù#ÚöåÑü>ïBŠçOv£šþjÁåÌ2,Ô3 rèÑ•ƒ µŠÊF\¬Ä%{Æíå˜Ï5±ÀaUÄùíeªyñ„Ü”óU9Òåˆ|DÃÑÞ„SxPÿʪ`qJh näMß•Ä¡*V’Äv3zY18rí;„dÎ`¹¯AtRèç#ÞtâRgÝxáúѲÊ׶§-Qr^¨q÷óþâCÞ]ËàhïãŒ~>ª!8þ”›Ö.ÉÀ–ˆ9Þø†Ñ†v<£I€aq*-Ïqe6J`Ðd÷IýIׯ6/‰%0ÿÛ&ðÐN8泋pÌš|}eìªÆ ðZ°˜Æëu£©çuRq ¼ÁŒ‚·«ÀïVk¿(À°@;b(&Xôç«Çïs˜Z7'?(ža°•XË–@èÞyª»G®±¼ëÈÔ;N¥›Žã^NPÇŒ £ìÙÐFx *œ5OJh|'’5RÝMFAL’4]CÙ7au %¢lZ„׶ipó)5TB4щº6• "æãuâ¿u:QCåº> ™* Œ8É EaWmUéIöÓ]ëS;!Š#ŒÆ×”µ˜)ÝqÙ_ÊÈsé2<’(AÌⶠh÷'»Fá¯hÄËü¤õ%%žˆâQ‚}dìÑPO1”™R/!¹V»vSëâPÆ1$•‹ó `0¼_Üɬ{úªŸŸ|Š¼~>•NåPOÒ +Öq¨LLµù ÿ$|aC®¦âƒ{Š"q¥=Û!'þM—ömFî‹e_ýP˜]êÇàÞZB?|ïD[Š£7RøÜaÌTBzÆ¥!Ùk³Þ™º4ïÈ(9;•ßKéÌy~§¹Tsb‰vU/f‡ë¤\hG'åKAÄ-¥,vË(†oÀy¤Rvi :¼eR&‰…ÊìÑÐnZ :ˆ3+üÝ’ë—&3Ý:¶©e<ƒ€´ÐXƒL|jð‰² ¯èWu×XŸž£Ýõ;—~êL1<ãš,Ê©‚xk݃þE•ÿN±ýÉ|Â÷7§ë×Ö7áÓ $eüå}4Ž69cÃ\ü’fÛýrƒ £ÕòÆîù;]90­g÷œrÖ'(yf3ÇEù6*ôǃ+<Œ&· ¤˜6ËN´gVf$àÞt-\|p>ZRÞþa_Ù¢ ql>j®µ[¸zÃÒÚŽtÊ•l¬3qó«æúžÔ&bN¼ü꟩#šÂjcþ’†sXÂúy8Tge" ­J¡ÆåÔ÷>¼w®F“åV8zC¼•RìÚ2ÔÈ0#áH-¸‘ÔÕ÷Ç{éB R½!ºLÁôT—Mü‹Ð&q3&Ý+HÏÅÀºÜ/2¸-H:ô¥S×[”|É3‹tÅ€y›ÀI­* j0µ•iãÐÕMŽŒo¸KÀ‰²BHQœ!–ÒÒ"%3-À å€ ëòÀ{]Sꢄ†­¼â¯ŒÊh»ŠVuùï#kühÈ`nìɇà*nwó>´u³l ‹úΤÏîNAs´ºVKõ|°|™`ãZÛÜ;POÆý‹(¤‘Ôœ w{8Áò5i¼02…መ’CKœíÞ¥fl¨×F‡âöLîî÷Nß™* â%Õ9nD¥f{zÓËz-^]ØkRà£Ï@º¢ÞÍ9À´ü𛆿ÈSž©1I“h-gk<ÏÕŻمåõƒA¶€d]%™¶1´ºì®vÔÈ> stream xÚí\YoÛH¶~÷¯àã½D¬}Ä[g_lgG?(¶âhZ^Z’»Óóëç|§ŠTQ)1÷áÂ`±X<µœ¥ÎV´œ•¨”r¦2®ò^VQUNÉJêP9+ =ˆ•×ºRžÀ´©´R•7ºÒ.T6¸ÊH³gƒ§QµyQYaQñ•õ€ò±r4º6ŽúIUÙHãYêe„¡1B¬ ¹L¢£öPE#÷œ %Ѹ*jZ” 8¡©‚ñU¤²Ô—Ö)itK¥’¾’FZª9à¢AÈT,Í ½bÏÉ@ƒ¹¨¿!Äi™4€%ÔµQTsÂUZ[Ôˆ$T£A¦6ah1ÎJÔÕÚ4€T õJÝÕ¨¯—d"8Oƒj€Ho¸FKò´$ª*ÞaDo >Pf‹Šk4JÔ '(áÒxµ¸GµH5å©hªœ¹#–æ´tÀ‘^Ĉy£%>yn#ìµa8Ê€yDy§,·‘ ™=íIL¼±4‡'~xO/¨¦ª M@MWQ©fªÈTóÄ~)ˆZ¨:0Ìq+Q†XÅÀ´À„TšH!”–­`¡5 Uê¦"ϙԒçYLµÁZ ’AU ᕘB%Ià*Xlx\’qŒÑJš@ä *u³‚ÓÔæ¶à©…k–“”b0š]:‰]@DH×!‚T…(D‹Á,¸MÓlLÖž[©›Ë!ªÊ yb‹ýæ˜$Ä;b>o&ÈkôΣX-4ÑÈÒ’” „*«H„u‘˜AìÄȽ_~Ù««O;NT'UýþÃGbÐö«Œ6I»ìún2ùmïŸÿÜ ­ƒho mÅ€˜º-´Ò§¶…VÁ°·„vbàýÖÐÊ ÉóvÐ2‚ŽÛB{5$[B7 ]·-´¢ûÒBŽo®çÕ/¿Tõ1I%ýŽ ÌÈ4Ö¯¦7秣yõ©ª_WõÙèÛ¼jÇ8ûûvD/†—£½ú€Æ]ÏgÐŽý÷ê“Ñìænz>š%ÉmÏGãáþÍ·ê,Š#ï£ú&N©7’X°ƒ’_ #c„M½w¿Š;í¯XO©uÐ6”ÛBk= =¸-´ðë¶]‰ rà¶Ú3ðbÛe[ZH 5´´ j ´ÙÚºÌÞ–ÐZ Ôú­½Z˜A”Û4"m¨mµè­Bæ|à¶&7ÉÓ€4ï¶ÐV àél -í µ%´Œb úA±÷;Za³"ødȆ§>ãùoÿÅÇÕ Ò"í@W\G1ÝÐÝ+5 µò‰¬½HªX8€ÿ·.¬Š–Ku”-BZÇ¡¹N}›R’{ÓvÛµóVCç[ÿ›rîî›N×n›ÀS¹¡“VÄé¶Q0ä’ÜI àtc+CÆ2ä2ÁdrhICä²@"Í¥¡±zÀ¡Í€ÜØn9éŒÈ€ö¨%ú0ð<¾­ê´iO&8òÅ"LBðH"Á\˜ü­Î†Œñ•øGí.@*á˜ÐXÌK†ôl° p|„ä(R»D®Û´7VêÛ”R$}ÌÝví¼ÕÐùÖÿ¦œ»û¦ÓµÛæX²S¹¡\lÝö!š©\R¸i⮀Eú®ô6ÂÀðå²X~š5(Vß#XIò‘ (Õ ›<È"$?`l[ïhï»ì xù—ŠÅ*P'Ø tòþHHÞžÇB°±‰µNóVQlñ#.¡#¼V,ëkí`¹¦,è†,¬)K†è–Ê$så[—õ êém ØͺA:=K;ñë\¾—ÎÃqÇ;"·(άÿã÷’˜jSݨ…"ÍOg1>ÏI혡Ção«×šq0Fs±IRHPÈt~d²ÚgÔqñúŒá÷Àë+a›;Ïe]ûÌph·®¥ Óî†`šu5kÄÍ½Ä u\M»Ï};øæyüf ¬w\<'eùn,8ѬœœßÅXq6¤t;,lѲ™m™í1ˆV°„6µ®ÛÎààC…†ÙM3 il‚‡‘Ž0¤Ø9—l‘x/Æü¡)C)v]%Ò˜²y¥ùìñMB£Kiô¢Ozè[³(]\ymŠºûéReZeƒ“u|åÇL‚È*¬AÞŽFˆ5Nq™q0•‚ H ‡2Ùßt0wùrR€Å@R°>Š‰ré4ëOž7ZŸ|z—Ô5! ™Cß>¥[0 (®DèT_EÓyÃQc™XšêN“Ì=|Ir¸Dæ§Ì3_°>ÕË‹)3oѨFbÕì¸FÄ¿wµðÁ,.fŽ´¼uÁªÏPy+7[¶T/ 'ý2\Û/×cÞâM{³V.¦…AU4 ¢³à¶Ž5d•‚{È*¾¼%ÑöKÞ}¹“9ÓÁίbÞKvèpÈ&8ò„säÙÅÍ‘$ñIvŒ%ÇéÈVŽì¢cqôlS½ƒ°…$~>rò!G5IÐ$‡‹¤éB "@ä(díM{ì¨Töž»–å˜Ñ5í¢æ,oTe8`…¶KŒ³7Œ®ÇÎR¬Ç8yd¸Àø¦a0Ž£L'yÑpšC Y5FÅD³L"BSØxŸôˆ´"9È’ã8MâÙ›åô@Qv©fySb›Æ¼2KÞºdw&ÀÂ7öœ ÷™åƤ8 «u‘°‰@9 H1ÈÃx a3—S̹ F¡‘Š}¨è9)˜Ý<îUº>¥Ë—Zbv-9ÖXøߥGÄžO§^B–~Téfç·ì?®úW?V–k+ã“’:)y“üYFݧH,! ÿØË¥wÈH1& §=Bbl]Qd™ó8©_$šP¿ä¥Ø’s.1IHÒë1©V=>9[©¯ä œ÷,ŽœÖ‰ì!EXy›ú25ƒ‰øÐjìŒêXÆTvéfX7Ú”U3‚•){š3d¬L \ žKåmì‘!@ –h-sË_¤™ÈùUέ˹=JÏY¸äósÕð:á€:v0K“$Écäïmú<7Ôú®ì•Žà&ð CäÛúÖrüµíj—á¤(±¯‹vÐL¹¡s° ¢JnšÊÙ5ÏÁ]*L> ‰œIã²Y|ŽŒgIO!r¤ØgÈÈ‹K~DäÓ(Η™¤ð 2oåSÎÛ¦X‰X?ÓA¢pìÊòg…’]>iâdã泯 ›l¾s¬RÒÎzùÜå²dIé3QÜÓH594m«94œˆ6o³U _ΉYkÛ€ŒUn(hmš‡¦øÙ$d4ÛbÑF¥k£ÜœôJG ¡^Û(·ˆ†A¤rF¤´Ášd7‹F9‹–ïe{Û'×Û0·‹›L™.Þ•a.¿äz’ÎÁÝ*±œEkh¿šFËa4?tòh ¤mâhÿC_¼Ù\v–²}·-M|YÛÚ¡Ã2ðâ¹ôªÖ‚"5˜ {NjSfqqR™ Š“Çòt3…òl>æ 뤠H²÷œŽå“Ÿm8*0~³g›ÆqœdlÜ”`çŽO|d:ò‘)»œÉ*»tXj’‹Ìç|çN1¤ÉX+:>ÌWæ»Õ%ÑòyäJ¹È /ÎÁšƒarþÿõ_¿Ò߈u6"'õ–l„3U:³ØÖFÈ°PùF„ïž³`†5m&Ô™öÂ:ññzkŠ³“漤9gömÏOr½1 M6ÅùLkJr¿ÒBp"4«áò|¥Õæ…Þnמë~ ÞÍKš,[z£Ö³b³…Þ%Û3[èÕå“,‚Ý3¾—hµèó•'-`ÑòI ·-NZÒ­nÄâ·âË`|Zx8šOÇ·ó›iúÔðÅðŠÞ¼ÝÿþñÓ<ß/½˜ /g•IûüyðÂøÆ”Ò!ÃD» ~8;ÇGÂ.äÁðöÑh|ù•ƒÛ«1 Þ=xùx>œŒÏ^_NF :]½Eò¯~Ÿ;ÑhŒ¯Ã)>jüŸúáÿ¦¹ÇÔC{Ê¿‡Ì‡W¯_¾yÃȸõ¸P,”pÑŽC÷ŸÇE‹^\ÎêózT¹¹›ÖWÃóéÍu}s=ªoëi=¯ç_§£Q=ÿë¦þÖÅXŠ]0>zvøìõKÆ8öp/4Ü‹öž¸çû¹WïׇõãúYýª~]ŸÔ§õ›ú}=¬?×ßê¿—ðT»àùìèõþÃÂó¨WL•!D#íi,2­j©%¢¢@“”zš¦ÄRËË[|"?}™ï//OŸ»OóE}ômQŸß¦ú#/àÇÏKó⡃0Èôæâî|~1žÝN†׳»««á|Œoÿ¿Í—(mv¡ôó£ÓGO‰ÒÏ÷QZ«,R„Þ$R µ½ê¥öÃz8¹ý ºœŽ†óÑ´דÑlVß\.‡´™–7ÛÝ'Ÿï%tUº²AW¹{B×Ù~t—°ÙI>|ûîõÙÆf½” .ÊÈ{Â%lÀ¥>"Uð‚ágR…ç7$¢õÅh2’ZüJlüWý{=©¯êkVŠ3R‹K¼T;)÷oOO?0ö~=+ìñχ÷„½ìžWëZ;é¾×ïONÞ¼`´zt¼j¬šðö¾6¤ÙÀÕýú€ÔüQý¨~Êü}ŪþŒ•ýGV÷-·[~ngã ™À|—õeK …(ð¾&3™÷6i¹Ñt|sÁÂ1› g_IDîê?aMê/Ñt'-÷îøýÉKØ““>%gDCS†¦­Aq±—¢‡‰FÜ 'ÉEhŒE¡òëÛÉÝŒ†¦7K¸ï¤òNNN_¼„’8éq’”h]}/¨¬õó FýËøÏì.ý«ë0­¥Çlü­ð¢Öe'Íyüá×£WpOzT‡ò QÅÜQ|¿<kBª‹ÞIž½xúäŽáIè±j®Õâ~ðq›ðYÂe'øþÓƒG‡À¥GÿéVÿiw?¸ôk?ÒnÓáùï£9Ëc®'‰\/ËW,_‰­ýÛ{4ŪÒ6Ÿþ]/Iø·52®wRzOß>|_çôC¯M”dš‚=|á² $‘õÇ,‰ý´œ‘úÏ~'Ïõkýy8m,B"!ŒAª]¯ï–L¨ÞIåÿ=y)P £VAŒÒ_#Åf'=xöüàpÿ9#ߧÔÇç•ø8ÝÇû@¾_Œ×!´“B:yzxp–ÒÏ6Z|·Ã?wâï¡~gäQ=œNoþJìZQNYª×òöóÝd2š×ãáÕÍõw!˜+(ôM:­Ýõ5ù»ß“ü$·¸PGr‡ãóád‰Ô;iÀï^üzôžH}vÖëñ’EQóÿM6TÊ¥ñØRZ)µ»¿{À)"Ä…0‡«fÍì¤ _ž½;øõÏO÷Ÿ÷¦0I)þU£ñïEjÈ-9q\oj¨´hN—˜t±;)·_Ÿ¼~ÿøè/ÆWŸïfÏo®Ÿ=8]Þõ¨9ä`À)š"ÈÂ^9eK„¬õå¾@Vk=Ne«Üúxï¸þ•öÈãú Ç}ωƒ/ÛD¢¿·õ;Š?p 8¼"!ž ¯/ÚDaáú½ÓëOÕçãéùÝÕ—Éè[v®š¨’âII{iôí|2¼ª¿^×%E•_ÿ¾ýJnT™g`ìúîê3­m|É‘f„Ѻd)eÏìú»›ùŠ€+ ’ãÓÑÕ8-rá½51ë‹»«ï®/hòó›éˆÙ¿R(»fØÝLÃþÇ×/²èœ7‹ŽÇN|n+«X&Á=r` ááÇÅV—º/¾+R@Vé®ð“p ‰—cb^„ôæWy»[ ¿ÿøà´Ù3'7W/nâ³øm“Ü]¨à”Ò÷‰®*t J,óÄJľtxWÈ{Ø9‹ýr¾$ö7“ Y¢Vú¯/ _9â éïÛ?*þ`ÔYº7ÉôFAÞÉN=<||òæl‰ŸdüT¡á§2?}èðÓvÌ–t[ȲaãgÙy~7õ«Ã>ÍG"L¼^æÿ˜üÙx¶€«$=‚0idár:üs´A%þ„dèæ!uà§E{£#§ãëËåF¡ÚÉCxóæÃÉÁÁ¡‚ô r 9¹,X®+Xx,Ã{6,Þ/æ_gé#×*§Mó/}º°<}ú5¨rzÄ]íôR‰bþèvŸéC‚•ùõFô¥’‹ù½»Ï¿|À¿²»¼Š l[àßÎÿlSi> endstream endobj 3762 0 obj << /Type /ObjStm /N 100 /First 913 /Length 2379 /Filter /FlateDecode >> stream xÚ­ZÛn7}×Wì{˜œá( زø";‘äØqÑ·R©]øR´ß™%W\RôºÚä!¥Ý™3sfÈC6Ñ8- ¾ÑV5 mƒFên”…FKhŒÇÆ(Aß±±Æ4RÛ8úÑil¤lJ.¤Ò%é ;iÈP*AVäMj°ô¦wô»VdGϬ“‘ô³ì’ð@ Y;Ca9BàØ»i@)CÞé‘HdÖPxŽÞñÀ/›…S¡LP’7kEƒàLã…k!¢gŠ§P9OŠNC¯Ya'§-[th½j¢A€cb€@¢´ž’ÅÀÄœBv Ê4JiŠAqäÚ ¹§ÿ”á(,¬ö©F9~j yöÄ2¥Z˜vd™p†”4 lÐÓ/ (XŠZ EH„ ¥ÅÒŠ#%"5½DÞée.R¡¨$œ"³g)@B#Š5·Ñ Œ è*¢™*ˆ¢wèŸHQ‰ˆº ¢å ÏÈ­À D³Ñ–˜¥pM J|Ëe `cù5ƒqžbô²gvˆb+Ì)A+¼š%h¥'Z)AËíÇ·Œ\DE¦@ Ze¹äô²¦Ü¡íDEe¡­n zÙQ„·uÖLØ—õÈ¥£Nô—ßq§%è€bJб{ Sì£Ó{N3:%èÚö¤1r” ³@ïP‚ζK/{F'§Î?@_¼ À¤§”èiÊ[:Gí®üÈÑËTóÉO?Mv–ÿþµjvïïž&;‹çßžÚ¯ü£œììÝ<®øI³3;X¼¿^¼™ÎfGRLÚ×÷W¿?Üþõtÿ@ @!ŠfNnŸ¦Ü<ÐüœìœÞt_€Œ.o¿<ýñÈMíË?ÿ¼EÇ׳½ƒejø2£{ð—5¾óÛãï~ºü¸íFLû“ËýÝK^vŸ«‡ןvR˜~éG¿?}~²Ûâë¼ß‚}x}yàk¯äpö¶ŸýøÓ÷g§ó¾Öù áeÖùfDçϦû{³¾ÖúJÁgà#üùÉþt:¯Öùj¸ñúk立†¿¾<{wpEðËeµñÕfç¹^NõÓW#gy9}÷f¶Ø›UñõFë¹þÌw™àœwǯŽÞœÝþùÛóãìþîôí|õõ¹ÈF"ö+Ùºpçàî÷û/·w_¹8#ÈYî]œžÅà7Ám´(k^Ðeãí îrïhºè˜›ßÿyvïOßÎV_nkñmtq¶|÷µË õCÂÛÝ?š_,‹ð^¢Ï†×or:Òýð..>ϧÓJxGO7ß*!9b&€ú…øáæëêq²3½¦€¨]>Ü<¬hÔ+[û“Û/Í/*èuT»ºÑ¹1|רÂgüÎxüùë(:'aŸÑðñ¹ý {x:Â…ïtpbu±aoH‡¶ø¶•´˜…LœÕãA\˜^¼'qÜÑbmã#ã‘$ß7a«O‹P¬•DŒhCNRÉïR:úS‘;©U7èò4"†cp»NP”Ñ1‡x~jdÜþÑÀ†–“.¶ƒt|$”1+ÛOz0éœÝ Ââ@‡rã¡@vŽ!, 4­ÌÝ#aØD„ÂX+@*œhç*¨° ð%Æ÷d¥M$ÇH*bf2Ø8Ë îãFBYÉq]2ÎDLç"”‡˜žÇíf°Î ¼Šäø˜ è6¤‡RÄ_d(Ú8(„˜ b\MQuŽU8oÒ >øþL~”Š«vM€*N'Ôu“x•@õ2T·zÓ@ÇíÛWéÂ, “iQl3¹áËXþôq¶¶W±aÒ߃#» ÚÛÛ0ýM7«âúÔ^݆Æö¯ŠoÀ^Àj¯{[nºõ¼½ìü½:e¼ZÓíõÜY¦°?~úv{Ç.ÚÝD'ï&Ú+âö[ð.qmzûômÅ—ÖáñnƒñœÝË+n><¬þn¯˜û[ŽÖã•Xk®Í]ŒãlõOŠªp¦’3™;묣/_³kkg­u/,YÁW> stream xÚ}Zkod5ýž_q?¡¿-„6„a6/uf± B=Iô¦“ X~ýV•×u¯»¥es}\¶O*»|oônƒôjpj.À£‡¿fP:Â_1hiiÝ ·j0lLlܘÁy Åàµ:’Ú A€VC0Ÿ C´ÐVfB#kI´þC‰(Ú˜W£08!"WRGl­µCD†ÊÃÔð7†!€¡·¸ä ƒ4¸"£R8#cÔx£„•z#´Å ”’G0D)˜ ¼QpðFmðFYaðË`çRʃ+ø?»€Æ`­<_´P ƒ‚¿QDƒ9q °ÖÞÅAkìôô4ZâüŸu$+v€«ð¤4Žð06ºxO@'7¥=>ùÁhO#`+hæ8§`!j˜ 5>ÉÁ ÐYƒ³=Xcp¨gR°F°ƒÅÎÙè_ðƒ“–°0€¸Zˆƒ³ ùEqÇYÀ]"ú‚zp,Hï•E.‚«Á-Þ)dÆ“žüàc Y ˜Ò I°ÆãHê!ðy‘Azˆ¦‡'‰aÅÚæÑW»õŸ´Ùǹ”ȶßmv¸Pî<[a+æÖéÃ3ÌóBO–„Ä/K:7YÒµK:Ó!ìì8Z-Zça×wæ’u.úsåÑ=&vÞš¾tit C«KbebûIJc|,œ ¾õׄfM-=[Ó¶ÒB²5¥,jÆwhQ×®Y¼žÌ5ÆËðx•Á™~/;Í  Ö,Z¦-=FK›CS±ÐuYé1&Z˜J1u2G>••VîÐT†MÕZB«CB+¶/To_¨QvyHvÉdW=Ùå(»<$»d²«žìr”]’]0ÙeOv1Ê.É.˜ì²'»e‡dLvÑ“]TÙãÕ#]tDUóx@òÈÅc<Ð;´ŽÅŽÚ¡Š¸Öedš¦ãH¨ÚÕIk†Ž–¡JéHé[)#;¥3t`~F+¾ÖX€ý¹Y-î•â±û¾Ú4Òw ª;xZ³}QÊEr·°K5) µ>øÉz5,“ ¬Ûì:>ŽwRoÙHV{{¥w¬¼“Â˧iï±kë´´¶Ó°ºj;òÕrZ,Ù4íQÒ«”c¡4T5mæ›Næ%S÷%N#;ªŽrR Û4.…(¥i¯2ŽgÍ$iÆ¢9©™eÆ4}Ç£±FNJ$+Š½š8–ÄIEdµŠ‘’{¥€§[“:t4%3ì]ŠÕËn¹«åþ°RÙ­”c¡½Yò¶sà×}}èiUwì‘í)¢ù[ÀäŽ9VÍ=K¥s²åx±º[?ÿýìócHФÞðÙç’Z"·µdnj©Ü ÔÒ©õâ T1ì¿åÍÝæ)ÏN¿L—Pã;–ª3àÚ*mj+j‡ÚÖÐÁÔ¶¡þXÛÛiµÒJÉ GÃÑ0Y§ñÔ®´¾{–¦ îê·"Ö¦²RÄ:>î8tX(tNÎ+Cíê¼²Ô®Î*d­¨mOí‘f ¶šÓÀ•’AF¤aÕ;MÎW-´ îꬖԶµ­¨íj›¼2¾Ã"gƒ MΛê¼&çMu^“ó¶:¯Éy[×ä¼i“W©>q¸R2èÐ0ä|ÕÂó¶:oh¯ˆê¬¡Ý"j¦võÂÐþIweÎ"‘€þ ôÝÈê«qÔ®¾Oíê«¡})GÖ‘Ú•5m’T‘&$ìqêï°‚&©q¶äº¬®[r]V×-¹.«ë´ÅtN;,hœƒMÕ÷8ŠFõ#âá!ª›11,)"É8‹vrŒ/f™ÜÉËí´µìd,‘úgËŸœþëù~óÇóú ˜Ú», ãif›wHêóEqÞ¡±£²o: uÈ)sÎn2â /–&Tó•uèy‡§3ïÔaç‘:æÂ(RòÅOòEQ¼Ÿ¯Cðó( €Ÿ@QÂ<ŠæÑW$d8ä ò› 9èE Ì# (azÎí Âsk‹ð>B9Š¦Mñ&õŒsêÒ4‘/e6&­èZÌ&ÃRèTÊåítzyv}ŠgO-㧗ççÇøhvö4Ë'«Áon^\?­vpxÕjðòìÍÕ›%f²"ïN’Y|ÿÛÃÃÓýà ®äGƒBZÂuÆÎpIøLÒ†·ž1nzéUjЈK½QÜ|*Š)lHI7…qã;£ïž±çœ˜ýþ¸ãLœÑ‡,V²”‚ŽÇé—.‚_7Yë¢ã  ´”†‚&[/ösÇ\n­gÔK'm _‚[Дåj SžKg'tÍ¡&Æ‘6… UÉËÙuÑi÷WI™ÈET2ïsÏaš6hÉQÝ™P$/ý$Ê&tóćYï¥îˆ|ŸBÍUTYÛ ™˜P™€"…a/o×ò&ë}¼u×9.£.gëda4Wµùäs˜DûžWfóD§5ÞGÜ¥çL|š'JR[sµ“ØU׋ï.ón…Ó]2´†w\½‡rÖz4ž3N}2OdØô$´ªw®Œêlkj2êjsC]¶çHæ5ÞGÛçéù¢$ªŠ£1£¾E“‡Ñ3Ó´µ`ÚÈP™'{Xû†µ’ûY§Ã&âÓ§Ã! Žšd«CmFY6¤¥…fb§m¨îÓVª¥í÷ÓÎa÷L¿uÏrÕfyRbÎñd~„¬¾íÖ ß°ŸnÌS7b¼ÊÛH o9*4‡SÙsž£*×*Çaâ¥ó¯MsÚ±Ò.Æ]â¯ÊVÒRLÖÍ{INHº,×.[Ãp8乇c†c|åÄÌ÷ÑÏÙí¹ÿéõ·ä{ï g–åb´Î$/^ž½¡/3¥êbÉfFæââ?$TVáâêôòŒf®ÀòòGrÐ.H·ZóðÒúgùá‘6ê,­i¡l0cqùpsµ[ÿ¶ù7N9Ï|s÷év³#0çè~úå³óÕzw÷úoüY¦«ÍŸ÷ÏÛ-“¾òd»&ü³ÔnÖ.v3~Ëæ¥AÅò«Å’ÝyËoKv½+¿`,ù…©|;X²«‘å}dÉ/G~^ÍZJܼϾ^©¤÷a²ˆÉïtšãùæQ>",y-ÇÈ’—.9œ*ŽQ®ë@eÅì÷zî·!L–öÎ¥ª|ÁƒD.ë GV[ò¤×§ß¿]RÆ樂ÞL’áŒëõOé`Ž0(gÛ[š16Ø9vú¼(`ÑõæŸõx$†ã‰4K Z½X̹ýï· ]S2—·÷ª?M¾[ï7÷oÏ¿y¹$_rü8ž{ù4øq·yZ_íÞo×iŠl¹Úþþpó[ú!ev&U£ÙŒiî¡Ï÷åþ•1úr_._ ÛnîÓ¯6Å«NS˜ž¦É|oÀ/ί^/à$€ÓMÎŽ¯‘·§Þ«ß¾8yõöììòW%ÐFÝ,ƒ¯Þ¾\ž_¾=ýþå¯Â ˜\Ÿ¼»|wò«ˆØkšÞÕêýûí_ ¼>Ør¡H€ßÝÝ=,è—ayßöð÷Ô1;{œ'ãú~æîšÖÎ×[S‡k;n×Û…x†{ïvÏ ¼LÙÈ&ºÝ~\(#ê"¥c·À ˆÇB×£‘ÝtÈo ïxSs¢ Çê÷í§… ¹U ßÝÞ."^—ʇ‡¯1à=¦~ðh;n±Ã›yÇ=´}G ±É€=nÜÝ‚”CY¿-Ï‹€ 4ƒ×‹ˆW7ÍÜÞhíË¿Œ øöööÃ"Šî’8Ç!Ãœ}/*¯Éˆ¾·Ï(S¼nÕ"8ÆâšáŸv%o8¼[/Þƒƒ›Á¸óB›†¿­1ÔôóûügKΊè»ðû3äº}™ÓJ0è W¸zhð«ÏW”Vµ.oWŸV7Ái*Ò¬g]V2ô•ú£òâö}'¶›ÛõÝÝz+4Þg4[h|.ßJþi½Ý®£ ß­`YÒ¼MœÝÃóú)ÓmC´{Þü“w¾Ìÿ.aæHËm:ªïÍãͪÈI[w¡ÐRlj7úãæv›Uná¿Ö›Ç÷ë›ëÝ_øly[ÿñ¼z‚òù…L/ŸjÓkšî:ÄéñAäÐÿTôK endstream endobj 3826 0 obj << /Type /ObjStm /N 100 /First 1045 /Length 4267 /Filter /FlateDecode >> stream xÚ•\߯¹m~÷_1{ZøfDR¿‚ hдIÐmlѧ$¼›»¶7ñÚ@ÿü’ŸŽæÎŒ8:ð>,dQùñ“DŽ¤s¹P\Ö… å%Ôbý_e+Ô%ƪ^—£ÂR3 ´„P’•x ²¢N–¬sḄ×WZJ ­Ùã¼U±RY(ô¨ e¶².T“™!aáP¬‡ÐÂmdѶ‘Ålÿ‹‹¬©¨I‹P©M 1•Ê"™Ñ¸.R£õˆëC¶v1,QVki‰‰¬]ä%Be‰²¤5™ŠYÕŠêˆiIqÅ(yI™0JYRèQ—²¢2Wk—Â’S°v‰–lµÄKY£áH²¨Ÿƒ•â¢–±êHi)™Ì§)/¥ Ú•¥†Œvu©\M[^—š€2Õ<”i©­‡:;¬a5óÕ¢°RBKed•PUMNZŒm•òµ¹IÿÖRÍJuQÐÆfzYµH«Ù¤Æ†ÀÉ”#?’«D…¤ˆM °YT[¨5«6#B4EµGSQTEA7Õ¦“ÀŠª=PŸUµqHŘW릳2°ÀtIj «‚MVÕV“MF6ÿ+ A(tV‘ªM’ú—«ŽÄ°hQµÅÕæ|ÕY"¯¨Um1†`EÕ³ ¨ÚbµIQÕ/:áu²kQµ%©è¦ÚRÖI©EÕ–ªÑWƒjËX UGTJ–ªƒRŽª-³²¬EÕ–ÅæSÕerÌŠ­Õ–“2¢EÕ–õ?+ª¶l4hQµåj“¯’j+aµÁHµ2§šg• ØKªMˆ-V›ï•lݦœ_ýâ¯~öû7ïŸZþôÕó??¿ùôöÇOá‰oºFVÝ-¾YöÕbÕáTÍOa½-¶„†ú`õi¬'­Wr‡z¶újõyõ³¯ß¾ûi´ëÔá/¯~ùK…ŠÕÞ2Àà§x[²úå\´:Ve«®Cuѱ•¿su5Èr ¡uì0@øþíŸ?>?™÷Ê]ýJgëøP§>! áP§:XtëÞ×E«ËÇ:…Ì‘¿ðÒðÊJunw·½ûéÓ»·?}zûᇧ×ÚÛÖÛPß08æQ`h¢È(0Hi-æ«e§ÖøüþÛçjî ¦MËN°šÉ©x¢QõD èꉢà‰":c:[:ôšc#ÃÆŽ>681AtÑÉ$¸Â+C§˜è6tšC*Ô3¤B’ =­\= 8.Å¡Wq{ãºN‘•ÛØkîó£O#æG%O!bOnªx"S£'‚‹kš k¶ÝÀAÕ#þ,«'AÕcŒ °º½"Ï“ÄÑ]½ÝæèH0®GEˆ<(AäÑ@¢ä‰ D®'+De ÏlºÍáajÏ¡¼B£Çƒ¡à1Ä`(¸‚¡àÍu†“OÑ 3“å8<‚ AÁ#ˆAPðb¼k¼Ìg¦™zî5'à'xüø!?äñ#à‡<~ü·>&™¢3[‡nà òDA‚È#H@ya§-º'S£K·±Û]Cì1Á{ E0ÄC ±‹ ±· "œÌq /†ÛØí<0ÄC ±ÇPCì1„€W< ±· œ,ë]¾Ýæ衆Äc(!ñJ`H\x`H¼eàd™ÇóD·±Ûx`H<†!äų3ƒ!ñBFR¼i‚œ¢ä9¶!›G;¶„çg}í£—¥dO„^ÅíEUO„z"|ϵ|ðŸ? øÑG#adqrIF¨"öD"ñD¢è‰*DÉÁ%¹ÎÁÅÛÐkŽÀOõø!ðS=~ÆTË9®?„/T'Ëd¤|*¢):Zoc·ððé¾zY¾¨" ËUädù¢Š<‚01‹ÜR>Žkž£K·±Ûå‹:®Çå‹*òb0\CÁPðb0¼UÀpò4Ël¶ÝÀCÁcˆÁPðb0<†°?€¡à-“C™£Ë·±Û€¡à1$`ˆ<† ‘‹ ‘Ç€!ò–ÀÉÓ<³Ù:t{ ‘Ç€!òÂV[< ‘ÇPCä-ƒ'Ó|×”r»ÍÑE0ÄC ±Ç¢EñX@°(ÞLG¬(ž*JšB‹|zÍ Bytò"i¡Z…¥x|؇ ®A‹¢àúsü,Ú4oÍ|ã ® yo\ÁÝT<‡ËC>PpƒpX'W‡m²àÛžýÝ®la¬\…±‚ÙÛ¢5)í7”Š\ø=+ràc+ä¾éÐ 9oöÃXÙÂX½ c‰qÞ|÷ñÍßüãïOú)óÔ^®öeˆÙ—!dÜ÷Ÿž¿³Gçÿ‚T0•¶”8øÓŒ;40¼ÆIçá Õù\ͨ.çjlØýØ奛v¿?|©Æ^Lô=Øth>1?c,:«(¨æsuEµœªu=»€àá¾A¼TÃaãIËÁ¤Cókë šéìe‚—éìe‚—éìe‚—ùìe‚—ù^ûf×zû$Ïz[0ÞXv´S'˜î¿x;õ™c²ßyˆì§Gž §zhðÄÔƒg¤Ù´7ùS8š:EƒË¥G³ÛÝm«û ±`å¬ñvãB‘<‰…Ã~”y”ØZ¯¾ÏFÀÂçÎêè³ଧØÖzuf`ð@E|ð;‹Wã±Ç`à¹ÓRKýmˆxžkñ-?ú a+&O`[ªƒ(aG}€(߆>3@V8vçöæv4¯¶WRäÚkG€Ïo¨v›2”ϳ®>ØÁk;z/Ž2 ¨yg÷!,˜ÊWBC|a»®WB;,žÅ¨ºíçç~.Êc#ËZò•f;T¼´ÙŽÝâ•P/Ùù {BnQ²¸h»ÝÎ s‹1Å…¬<´m´^I §»WRÛxÒÕÈ@Fû)|ãäLæÈïæûÝ@G+œÅ•Kl‡ôç7Ä8£Kâ6ÿ‹\Š ‡h—bœ~ÑÇà÷ì<|¢z¡-ÄU.Ŷˆ×r)¶M*\¸¯å¬9^IÎêCø²eçîÑß³à Úü¼ÂÞ¦çôF}HWRœžßgþ§7ß¾Ã5aÊáÚöãÊÞcØí •÷£c*õ÷­ ¼_YÛ[³M˽ý›¶àþW8ßÏ µzz{aXÀÿªc¿~½¿·éßç÷KÎ÷Ë>-”^èÊÇÄêµýÅ‚¯~õõ¿ÿÛçoÿùùy?ºŠÒ--ÝÒÒ-½/T-t3Æ·ÐûÁí®â·ßÿøã§?~:ü¥†MW7¾tãK7¾vÏÕnϸÐ_ƶüãw¿ÿÏ?üù«°þù6*ªBíj‡P»'k7¦¹Î}è C7=¿ÑUWÑÝþrÏ?µzz{AÀàüû¯_ÿê7ÿûõ×øëZºÆwÏÿ÷ÝÏÃ8¿ u$Ô‘PGBÝêÆŒ?chƒ¿ýÛóû÷ÏïV¾þK]wÜapw*wS¸›ÂñKþ¼ÆñGñ›Â>)¸Ãᇻo¥%áË~¨¾ÿEiW(t<ÒñHw­t£$Ñ> endobj 3927 0 obj << /Type /ObjStm /N 15 /First 138 /Length 506 /Filter /FlateDecode >> stream xÚ}”ÍkÜ0Åïþ+tLZ*kf,K!ÚKé'¥=•¼‰ †ý¢öúßW²ýH7öæöó¬ôÞ›ÑJ¢\gD9ru5ì$¤²£ dª©ÂÆgSs•¡2¡×xÉg¨ºP$IÆmIš(fRCLÙ¥r‰4§í$ÄÅÍMQ~ê{ó[b3ý0  t†à”á¾(?w»nHû¯¶ý°?í6íûÎ[ÖksulžZKáú¾¸½=s T@š^:Mº~ÅÁ‚G@ˆ(«ÞÁ òÒ!"pDàˆÀã‹HuÕ!JrèÛ‡¡;ìßX^”"µ"µ"µbtŠ$ê_º_¾’ù…›D¹sddêò•¼x ‚¼‚¼‚éI\ÿBéCÛ§Ç3-GõçßckÊ÷ÍÐlOEù=%I‹Âô\å·Ó°íöS)L¥¯Í.ç÷vüÎ[¾ÛòWßbyÚxl÷wãŸm|égÇ°ûtq endstream endobj 3943 0 obj << /Type /XRef /Index [0 3944] /Size 3944 /W [1 3 1] /Root 3941 0 R /Info 3942 0 R /ID [<4625D5302EFBE5C0283348B766107AB9> <4625D5302EFBE5C0283348B766107AB9>] /Length 9241 /Filter /FlateDecode >> stream xÚ%ÜiŒcmZŸqŸZ»ªºÝÝU½wW/Õû¾ïû¾ï{»7w‡—agˆý†I&0²ù‰ $˜”% J†ÄPr ˆ@p&l!…$‚Ę€“D›cĦdâßÍûázϹ«mŸó\ÿçñyÎâTjà¾6J ¤’TjqÿSûRéùÝj ¨]VÛeu†Ôn«í´: #jÕvX…jÔ¶[ƒqµÇjÛ¬NÀBµ'j[­.‚´Úsµ-VÃ’~mvLm³Õ¥0©6®6cu –©M¨m²ºV¨-TÛhu%¬R[¤¶ÁêjX£¶Ym½Õµ°Nm‹Ú´ÕÀzµ­jë¬ÆlTÛ¦/‹ŸQ» ¶Æjløµ‹jñ‘±ÓÛÔž©­² ¶C-Ú 67{—ZVm…Õµg 58´L-vu/ìS[®¶Ìê~8 ¶B-šé R[©6iõ0Q[¥M|Ž©íT[bõ8œPÛ­zNÂ)µ=ji«§áŒÚqµP{ΩP[hõ<\P;©±¸—Ô"kãV/õ{j©«p­_˧ÔX½7RC3jÇ›p«_+¯V±zQ‹(ß…{jkÕ†¬Þ‡j§Õ¢<„GjgÕ¬>†'j‘ûèBOá™Zä>eõ9¼Pëÿ5=÷ÑêKxÕ¯uìÇÜ«x­&“sY«oà­Úµ÷VßÁ{µx¿XüAM†æÞZõA~gù™þg oàý¶´1 vNíµU{Ùèïþp-6ȶ4´PcDíÚ+«Z·±@ÍNÏÙ3q5{î…UV}Ý#G«iƒ†D4Òj7ÔžY•¦Æ5AŸÓ~ Ilô#:R<¯öĪ7–©]RÓö = ÑÏøH/¶ù‘U½§±Jm»o =¯±F”¹VõÚF¿;~ª“ÌqÞÐÙëÕ„fîžU½±QÍ`9'/ ½1£&˜sw¬êì~gmÅke­¡³7¶©M«Ý²ª³7v¨ÝR“Ó†ÎÞØ¥vGí†U½Ñï[ NF;ËxCgoô;û‚Ê:µkVuöƵkjúGCgoR»®vŪÎÞ8¢m o5töÆ1µŒÚ%«:{£ßWÇFuˆ9ý²¡³7N©Åç^°ª³7ú‘š˜¼©¦O7töF?R¹jç¬Æ.¨R‹ozI-²qÆjlPK'Úß¹xûØ™þn-Üm°œ;e5¢ßB‹²ž¹Ø´hÄ[jGÔNX wÔŽªÅn…¼{jÇÔŽY ñÔ|ñÍE“Dh©]Q;b5÷DíªZ4g„õ™Z´ý!«ôj±Í¡":É+µèœ¬Fë÷¼EÍØæгßuÓ“Sjû¬êÝ÷jÑνñA-2´Çj¿³'_ìwöÍ¿é þ‹ Àp’Zt3jƒ0ä¾+æ&Á·éœ¯“9ß—s+ý“QXc0°AÃX “0Ë`9¬€xÓU°ÖÀZXÓ°6ÀFØ3°¶ÀVØÛaì„Ý°öÂ>Øà ‚ÃpŽÂ18'à,œ†‘$µtC4ØI8¥]¢ÕF¬î‚sp.ÀE¸—á \…kpnÀM¸·áÜ…{ðÂ#xOá<‡ð^A^Ãx ïà=dá|t|| ÄaÞ ÄÁÝ0Ä!Ý(ÄÜÄáÛ,†&I­Yo%/™xûûð8I}ÛpüÁ‘Û”Cµ©t’Úÿ>jKÁ¡ÚÔrp€6µ–M­cSkÁ!ØÔ48ðšÚ·¦6ƒ¬©ÍàÐjj+8 šÚ£¦v‚ƒ§©Ý°öÂI8§á ‡©$uàilé>¦c÷ÀA«Ñ`1|é—™¬ÕÃpŽB (¾I&uñÉ 'gÂfô²ÌRp¤•Y Kü“pߪoˆIý<ãûcÒÑu&>mø~Ëè¦#p&Úï,œƒóp.Â5¸7à&\IêÜ‹½ŒïÐØŒõ Þ™a#Æqb&4Þ«IêÖ—ãµ1æ„·{p^ÀÝ$õøŸÄ?yOἂ ¼†7ðÞÁ{ˆ6ýàx7B(±³ÞjVbg ˜•ØY‰•ØY‰]šJ ÿõ×,ÅÜ rú2I½ûÉx­(Ϧ}O÷wf¼´ÔáQâ+æ¡c•çIê§î§yÐ8ïSS 9‰„œÎÆôANgcÒ §³1UÓÙ˜ ÈélL äo6ÞervI’úÜÿŽ Ú¤éâXeØÑÈ_©û`=ìaÛÙXÛÙ}°drö !œ­ÂÙc ϳ'@Úg¥}VÚg¥}Vhf…fö2ìHRßûý±i24{ÉAj½~ÔB 8N¬ùNžô…6ùÀêc-)ã™è+«op<ír„pVþf¯$©ÙŸáh$RnÁm®Ù» M³Ò4+>³á<†'æñ.7“Ô?=K6+z³/AÌfÅlVÌfÅlVÌfÅlVÌf#a:Ýœ^–HRñ8å`†`F`ÀŒÃ,„E†Å°–Â$¬…$IýìºøŒ)X ŽE‹ý;~º¿çc…˜ãLÃzØaÌÀfØ[al‡½°.IýR!>cìrXv ÞPöŽÐóþ°bfxb>xbxbN·/I5Åû×2u’››¨Åï,ÄÄ.Þ9¦s!&q—!vë*˜° ]‡pÀé$õ_9>(F•Ò-~îÂ}ø®É:L^ï˜5ì<†ÈSxÏἄW×I²d*IÎ|Þçæc&©ÿu(6ã ¼…wð²ð>šd&Iòƒ‡ãµÞ4ïMó¯Ákó^›÷Ú¼×æ½6ïµùx­øä’d@€‡fâ]–Y„!†…àKdn,¢yÍ'ɲ_îïÇŠ•Ö¼°æ5]~,IV¾íÿuÕ™øëx’¬>KI²æûX7ÖÇôÕ¨‰r^”ó¢œ_œ$ë¿;þ°$I¶ýu, u^¨óRœ_+`%¬ÉÎÇFÊ}~p”ê¼Pç…:/Ôy¡Î u~K’\ºÒß–Ë?ÔÇ•ßïãÚ¡>®¡ÿ¹[[û¸ïãÎWú¸·²ûŸéãÁ/öñh¼Ç/úxòÓ±¥úG^ÿÈëy"¿vÁnp%¯ãä9Éëy½"¯WäõŠ¼^‘×+òG“äé_ôßþÙ¿ïãù¯öñâçúxYéãUÿˆ;Éûxý÷úxó }¼}ÕÇ»Û}¼?ÓGvoÖõñqalß±$ù;“±t>û'}üÝ}}ä¾¥üÏôñéWûøοM“ó4ù“ 'çOƒ›×aó:l^‡Íë°y6¯Ãæuؼ›×aóq†E‡Íë°y6 nƒ~™×/ó÷à>èÎù‡ Kæuɼ.™š$ŸûºØ´gIòÝ¿K:g^çÌ¿Ô§ÍH'˘tþ`òQ’üZ)úÇBX ýØþh=j‹ ‹a øfŸ™„)ˆµV@œ™Y•$•ñ.«a ¬…u0 ëal„M0›a l…m°vÀNØ»aìÕkcs÷Á~8á†#pŽÁq8'ᜆ3pÎÁy¸Áw÷Ìe¸Wá\‡8=vœ›¹ N…ÍÜ'ÀfîƒÓ^3ÁÉ®_ô3NqÍ<‡3ÏÁ鬙—à$ÖLœºšyNXÍøÚ™qšª¬ÅË €±®l¬+ëÊƺ²±®l¬+Á8L€”5b™ó2çeÎËœ—9/s^æ¼Ìy™ó²Ð”,3X«“äçÞǶ¬ÎËÓIò§Ÿš6-ÇÙ<í\æ¼Ìy™ó2çeÎËœ—9/s^æ¼Ìy™óò^ »Lw™î2ÝeºËt—é.Ó]¦»Lw™î2Ýå8cµ¼!IþÃbÓN9"§e~Ëü–ù-ó[æ·Ìo™ßrœôä·§:ù-Ç N~ËqZ“·2å‹Iò[ïâ3:†Û䃢ÙY-³ZfµÌj™ÕrL„UݪB_$ÉW×Ç»8)1·68sÁj‡äÉ’;$wHîÜ!¹ãÓ:$wHîÜ!¹Cr'ÙIîÜ!¹Cr‡äÉ.;ºsGwîh¦µz:ôtèéðÖL’¿ù¦Ø4½#½#*Qéßá¼Ãy‡óµj;Ôv¨íPÛ¡¶Cm‡Úµj;Ôv¨íPÛÑk;;’…Ÿ‹gº£cwtìŽþÖÑß:q`-„½»#½»#ö;ìwØï°ßaµ#èˆ@G:"ÐŽtD 'œÏ%Ówb3„¡£Ow^:x? ç!>7ÎD߉óÏÄwâ¬sˆsÍf ŸÄÉeS…Oâ”ò 8‘üÉ08}üÉ(8iüÉ8UüÉ,„E†Å°–Â$LÁ2X+`%¬‚Õ°bþ±Â~&ØóDZik„zE2ðá_Äê&˜Í°¶Â6Ø;`'ì‚Ý°öÂ>Øà ‚ÃpŽÂ18'à$œ‚Ëp.Ât2pý'cÓ\nȸ61ùÁ6?Q» ×à:Ü€›p nø ÷à>˜¦}bšûÉ#x ñ~Oá<‡ö_A^Ãx ༇¬ ¡5X‹KaúR2ðô{b?bò(µ8o¶ÎÎØ‚ÚÃd d¾5\“ƒZ\2ƒšÔä &59¨ÉAMjrP“ƒšÔä &59¨ÉAMjk`-¬ƒišlÔd£Æ~ß¿5~küÖد$ßúÏbûd£¶Õ\ã&ÜpÖ@×ä &59¨ÉAMjrP“ƒšÔä &59¨ÉAMjrP“ƒÚi8z^íè~µ µK /5y© CMjÂP†š0Ô„¡v;•þ›¯¥R¾f•Ë—5jkRR‹]’¿5~k"PÛž |×—cÏŧ&%µg¦}£Í.5¨EÄ¢3Ã8‡’À Â8Éqt„Š—ÉÀ?þáøÇ#°Æ NBÇM@\5Zq­h1Ä¢¥àºÐÑ)X.ÿ] .ú] ¦×G×B\¯Xb&œ1ƒôŠ^þñaÌÀfØ[al‡°vÁnØ{a…õÉÀ—6Ç;ï‡pâÜá„n{tNÀI8§á œ…sp.ÀE¸—á \…kpîøǒ¹‰m¹·à6<„GðžÀSÝÏἄW×ðÞÂ;g0âíï&¿öŸbé=|€8Ã2íŸ\v•ç¥=_ TäéL«­ÖX]— ¤½KQ†Š2T”¡¢ å¥( E¡) Mqä¥(/Ey)jÝ¢¼å¥(/ŸŽ(/Ÿz(E¡) MQhŠBSŒs2BS”ØbŽþÛ?´bgúcɪ€…¦(4E¡)FMhŠBSš¢Ð…¦(4E¡) MQhŠBS”’¢”¥¤xéâ1—¢¼å¥(/Ey)ÊKQ^ŠrP‹âÆdàþƒØp*^þך}nÛ…ØR±(ÞgvŠR¢øï‚\åª(WEÉ)JNQrŠ’S”œ¢ä%§(9EÉ)JNQrŠ’S”œ¢ä#9¢RÌ‚¼ô˜îÅ)Ñ°5øó± e#® ^•§Éà‰?ó‡žDô$¢'=‰èIDO"zÑ“ˆžDô$¢'=‰èIDO"zÑ‹A!®"KD/®KD/®KDOz"Ð[Ò3xôä '=9èÉAOëöèîÑÝ£»GwîÝ=±è &ƒ‹ê±3.ºÊ9­«Ÿ!=‰èIDO"zÑ“ˆžDô$¢'=‰èIDO"zÑc¿géAzFž¤gé‰JÏÒ“œž0ô„¡§ù„¡' =aè COzÂІž0ô8ï‰@oW2¸ö{bgârõR{´öÀ>ˆ&ž€ô¤' =é HO@zÒž€ô" ½A €A‚aQXc0°A\X K ¶t¦ œ?Kw­ŽO‹+£îh¹U µÖŠã†dðÛ¿3þIÜC0 qçÀˆû6AÜ%°Üð©#ŠOC÷vpÀ§;á¬M¯.7ÝåHð½¥CpŽÀQ8ÇᜄSpÎÀY8çá\„Kp®ÀU¸×á8âùô܆‡'`&ƒ)¶ï<‚ÇðžÂ3x/à%¼‚øþ} oà-¼ƒØKgu?ýL·|F‹éÓ-¦[L·˜n1ÝbºÅt‹éÓ-¦[L·˜n1ÝbºÅt‹éÓ-¦[Ë`9¬€•@Y‹²e­¸#„>HßýXlÕªd°ôã)÷e,‡°VùëmK«a hºVEÆ] œ·âÞÎ[qÇÇnÐIZºKKOií‰hh‰@KZ"Ж´D %-h‰@KZ"Ж´D %-h‰@KZ"ÐÉ­Îoë.lL¿ëdì¾”´8oqÞâ¼Åy‹óç-Î[œ·8oqÞâ¼Åy‹óç­8“Ïy룶Š6M`a†aFaŒÁ8LÀBXiX K`)LÂLƒ‹'×úÜ{Éà÷ŸÏ]– ~åÛbil„M0›a l…m°vÀNØ»!îÙÙ îÔ9¹ÜŸsò ¸+çäap/ÎÉ£àœ“ÇᜄSpÎÀY8çá\„Kp®€ï“÷á\‡pnADôÜ…{ð žÃèŒýÔ/Ek<€¸a(Ú弄W×ðÞÂ;xYøüV¼_…ß ¿~+üVø­ð[á·Âo…ßÊx2ø{/#¹Br…ä É’+$WH®\!¹² tΊÎYÑ9+ñåª_VôË +4VbßúÇ¿ðñik“¡ñÏÄ’6­\!¹Br…ä É’+q;É•¸ ‹äJÜzEr%n¸"¹·Y‘\!¹Br…ä É’+$WH®\!¹Br…ä •~Gü¿›ÆyED+"ZÑÊ–dð!þÊt…é Ó¦+LWd£Âjå!Za¿r3ü£­ñÚG •§¾éÜÚ” oÄWè®a(0]`ºÀtéBÜÅÀtéÓ¦ L˜.0]`ºÀtÆBô2~ ¯€ýûö ì×ãs¯'CO·Äñâ Ä>$C?tÊêt×™®3]gºÎt=îM!¹Nrä:Éu’ë$×I®“\'¹Nrä:Éu’ë$×I®“\'¹Nr]ÂêÒTgµNwÆ:uý·ž$Cßú…ØÈisØx~ëüÖù­ó[ç·Îoß:¿u~ëüÖù­ó[ç·Îoß:¿u~ëüÖù­ó[ç·Îoß:¿u~ëüÖuÝ:ÉuBë„Ö ­Z×Å뛓¡¿ÿ;±áž_˜Ûäüyuºët×é®Ó]ëGt×é®Ó]§»¯ »Nwî:Ýuºët×鮇n~ëüÖù­ëØõÐ$0ƒ0Ã0£°Æ`Œ¶§—Â$LÁ2X+ ì_K†Š_ŠÏ˜H†¾ò§±äž±Ó«`5¬µ°¦a=l€° f`3l­°ö€‘ÿ´‘ÿô~8;aq2Tþj|î68‡à0£p ŽÃ 8 §à4œ³pÎCÜgt.Áeˆo««p ®Ã ¸ à!܃]ÉÐÏìM»à1<§ð žƒ/´Ó/ádà5¼·ðÞC>É®ù—H.‘\"¹Dr‰äÉ%’K$—H.‘\š_½%_½%~Kü–Âùýdèÿy¼s:ú«ÏÄñ¥¸'ß¿%~Kü–ø-ñ[â·Äo‰ß¿%~Kü–ø-ñ[¢¬ä+¿ä+¿Dhi_â²Äe‰Ë—%.K"PšJ†~ó;c«ö‚&.1]bºÄt‰éÓ%¦KL—˜.1]bºÄt‰éÓ%¦KL—˜.1]bºÄt‰é¡%G(¥8B¹ œ—ä Äy‰óç%ÎKÔ–¨-Q[¢¶Dm‰ýÒd¨ý_bßâÆ÷h:ÎKœ—œÜs'ÌĤ›2'`†`FÀ‰ËÉ0ã0 a¤a1ÄÉþ¥0 S° –à X «`58ÿ<é¤Îä:˜†õ°6‚¡or6CèÎ$Cô!¶~K2¼ýó±´vBÜ‚·öÀ^Øûá„CpŽÀQ8ÇᜄSp♋³àI‹ÉóàùŠÉ8Óë©ŠI'Ý'5¼ ·a{2<üÙØÈkpîÁ}xÁÉy7äL¸gÂ]9nüœp_ó„ûš'&ãpõ-ÜI†—~K¼é+³ǘ™íVßC>Ó9ÿ.ÇtŽéÓ9¦sLçÍš#4GhŽÐ\\2 4GhŽÐ¡9Bs„æ8ʱšc5·:Õÿïk–¨ÍÅ÷y9òr[ÀÁvnØÜo9Þr¼åxËEÖÞ%ÃëņǮ˓áÏ,‹UQÉIIn<>ô—Q“¡œøä8Ïqžã<ÇyŽÐ܆døì\ücȉ@Žøñ¹¸‰<6’óç9Îsœç8ÏÅÓ5œçâ™Îsñ$M\há<ÇyŽäœÙDÎ¥ËÜMx¼åÞAN$÷ŸÄ¹_4wd#'9ÙÈÉFN6rb‘‹œXä$"'¹W­X">G|Žø\œ¿÷öí¸ïšø6ñmâÛÄ·uñ¶.ÞÖÅÛš½­‹·%¢-m‰hKD["ÚÑ–ˆ¶D´%¢-m‰hKD[Ú\¶¹lóÑæ£ÍG;t¿N†_þqlšÐ´ã*TœÚe°Mm[®ÚâÓŸ63mÉiKN»ß£þ‘ákáî¸'ß³ ‰f$¬Íy›ä6Émý¼­Ÿ·énÓÝÖÏÛbÑÖÏÛœ·9osÞæ¼Íy›ó6çmÎÛœ·9oSÑŽIºÚæ£ÍB[m¿‚Œí‹6«n;“áïø¾Øiyi H;®m H[ÚF‹¶´E -í®iµ¶+ImAj R[Úœ·9osÞþè#£]€A‚aQXÑØ“áÏÿd¼lÂ"X “0Ë`9¬‚éd¸v(^¶â¦Ø [`+lƒí°vÂ.Ø ñÕ»öÁ~8á†#pŽÁq8'!îÓ: gà,œƒóp.Â%¸ W .mÅcn×áÜ„[àŠÝî;pîÁ}x ïà5ô‡–éEC°µû9Ä…×èœrP&yYˆ›LتzY•­*[U¶ªlUÙª²Ue«ÊVu 8ªº¢]%ªJT5 .óV—oUÞª¼Uy«òV]+Áª‹ÀU7éTׂ»EªfJոܪí«Ú¾ªí«Ú¾ªí«Ú¾ªí«Ú¾ªí«Ú¾ªí«Ú¾ªí«Ú¾ªí«Ú¾ªí«Ú¾ªí«Ú¾¦ß$Ã_Z ±¤©*MUiªŠOU|ª’S•œªäT%§*9UÉ©ÆC¢ý‚ß‹·bµÊj•Õ*«UV«q–Õ*«UV«¬V£«9¬>‚ÇðžÂ3 ¶úø­ò[ ¿rP}²Q•*ÝUº«tWûºM§ „!†…0ã0 a¤a1,¥0 S° –à X «`5¬µ°¦a=l€° f`3l­° ¶ÃØ »`7\„Kp®ÀU¸×ÁÓ£Ó7Á3£Ó·!Rr0þ•ˆÆÙ{aì‡pÁa8Gá‡pNÁi8gÁ×Ïwgf’áÿñ¯âÓ<¦:}<œ:}<’:ý<ˆ:ý<~:ý€d}xV²r•ƒ¬då +Y9ÈÊAV²r•ƒ¬då +Y9È2“e&ËL–™lx» ÿöïħ‰JVT²¢’•¬¨dE%+*YQÉŠJVT²¢’•¬¨dE%+*YQÉŠJVT²¢’ÝœŒ\¬ÄÃrQ‹,ƒÙ­ÉðŸýzl”d©Íš%4Kh–¼ìþdøÿm‰Ço–Æ,Y³4fiÌžƒóp¤.+RY ËžHF&~%ÞE³ñhr.‰šÇÌÍÀÓfàéÉxFÖ³¥fàéÉxØÕ-¯sñ¹ž<5 OOÆó°N5 O›†§MÃÓ¦áiÓðôd<”¨ã˜§'ýÞƒxÚ ÷/ãñ„›ß”0ÇNg¢‰3ÉHñ}üõ5¼IÆþË1Âi’ÌÂdäG›±ê·m2ö<7ØóŒ=ÏØóŒ=ÏØóŒ=ÏØóŒ=ÏØóŒ=ÏØóL<ï÷ì~Æîgì~Æîgâe»Ÿ±û™ø.³û»Ÿ±û»Ÿ¹œŒüôÇت+ÉȯÇÒÕdä?K×’Ñ…ÿ.–®'£û¾K7’ÑÑ™›Éè7_,ÝJFKã±t;ý×Kw’Ñ¿üÛÚÝdÁêݱt/Yp6K÷“/þ8–$ rWcéa²àÇãÇb2’ÿö‹±ô8YÐzKO’UŒ¥§ÉØÊKÏ’±Cÿ'–ž'c/~,–^$cŸþn,½LÆ>ߊ¥WÉXcK,e’±ßùÛÚëd|Ó‹Xê‹úŽ?ˆ¥·ÉøoÄ¿›‹Ÿ$‰+qDÍ5·;ÿ­ß³‰_Òakž­ùøq&¶æÙšgkž­y¶æÙšgk>~l'~]'~N‡¨ùøá¢æãçjˆš'j>~(~Žˆ¨ùø±'9—Óy]wÞSºó":ï'æ=˜9?ÊãÇIæEt>~Çcëó~f>~ *~'~ô&~ÝÉã\óñGñ£Fžêy‘Ÿ÷{#óò<ï ÕyOÊÏKݼ'àçã' #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.1.2/PORD/include/macros.h0000664000175000017500000000434013164366235016562 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.1.2/PORD/include/const.h0000664000175000017500000001027413164366235016427 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.1.2/PORD/include/protos.h0000664000175000017500000003223613164366235016631 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.1.2/PORD/include/params.h0000664000175000017500000000157013164366235016563 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.1.2/PORD/include/eval.h0000664000175000017500000000427113164366235016230 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.1.2/PORD/include/space.h0000664000175000017500000000276413164366235016401 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.1.2/PORD/lib/0000775000175000017500000000000013164366235014247 5ustar jylexceljylexcelMUMPS_5.1.2/PORD/lib/gelim.c0000664000175000017500000011777113164366235015526 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.1.2/PORD/lib/Makefile0000664000175000017500000000137413164366235015714 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.1.2/PORD/lib/nestdiss.c0000664000175000017500000002531213164366235016252 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.1.2/PORD/lib/minpriority.c0000664000175000017500000004151413164366235017005 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.1.2/PORD/lib/bucket.c0000664000175000017500000002006613164366235015674 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.1.2/PORD/lib/gbisect.c0000664000175000017500000004254213164366235016042 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.1.2/PORD/lib/ddcreate.c0000664000175000017500000007447113164366235016203 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.1.2/PORD/lib/interface.c0000664000175000017500000006507513164366235016370 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.1.2/PORD/lib/gbipart.c0000664000175000017500000005155313164366235016054 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.1.2/PORD/lib/sort.c0000664000175000017500000001410113164366235015377 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.1.2/PORD/lib/symbfac.c0000664000175000017500000004453313164366235016050 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.1.2/PORD/lib/tree.c0000664000175000017500000007632513164366235015367 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.1.2/PORD/lib/multisector.c0000664000175000017500000002653113164366235016774 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.1.2/PORD/lib/graph.c0000664000175000017500000004031613164366235015520 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.1.2/PORD/lib/ddbisect.c0000664000175000017500000007230413164366235016202 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.1.2/ChangeLog0000664000175000017500000006532313164366235014520 0ustar jylexceljylexcel------------- = ChangeLog = ------------- 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.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.1.2/INSTALL0000664000175000017500000003241613164366235013774 0ustar jylexceljylexcel=========================================== MUMPS 5.1.2 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) 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.1.2.tar.gz % cd MUMPS_5.1.2 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 , ./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) -------------------------------------- -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 also based on the same OPTC) 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 Platform 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, by the WINMUMPS project, or by visual studio project files provided by Free Fields Technologies (see main MUMPS website). * 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. * MAC OSX ------- Dominique Orban has developed an Homebrew formula for MUMPS. Please check the links page at http://mumps-solver.org and https://github.com/Homebrew/homebrew-science * 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 later 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. See the FAQ for compatibility issues between mpich and gfortran. * 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.