mumps-4.10.0.dfsg/0000755000175300017530000000000011674430272014107 5ustar hazelscthazelsctmumps-4.10.0.dfsg/Makefile0000644000175300017530000000360111562233000015531 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # topdir = . libdir = $(topdir)/lib default: dexamples .PHONY: default alllib all s d c z \ sexamples dexamples cexamples zexamples \ mumps_lib requiredobj libseqneeded clean alllib: s d c z all: sexamples dexamples cexamples zexamples s: $(MAKE) ARITH=s mumps_lib d: $(MAKE) ARITH=d mumps_lib c: $(MAKE) ARITH=c mumps_lib z: $(MAKE) ARITH=z 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)) sexamples: s (cd examples ; $(MAKE) s) dexamples: d (cd examples ; $(MAKE) d) cexamples: c (cd examples ; $(MAKE) c) zexamples: z (cd examples ; $(MAKE) z) 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-4.10.0.dfsg/examples/0000755000175300017530000000000011562233011015711 5ustar hazelscthazelsctmumps-4.10.0.dfsg/examples/zsimpletest.F0000644000175300017530000000330511562233011020404 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'zmumps_struc.h' TYPE (ZMUMPS_STRUC) mumps_par INTEGER IERR, I 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) C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NZ ALLOCATE( mumps_par%IRN ( mumps_par%NZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NZ ) ) ALLOCATE( mumps_par%A( mumps_par%NZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I = 1, mumps_par%NZ READ(5,*) mumps_par%IRN(I),mumps_par%JCN(I),mumps_par%A(I) 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) 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) CALL MPI_FINALIZE(IERR) STOP END mumps-4.10.0.dfsg/examples/Makefile0000644000175300017530000000367711562233011017366 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # topdir = .. libdir = $(topdir)/lib default: d .PHONY: default all s d c z clean .SECONDEXPANSION: all: s d c z s: ssimpletest d: dsimpletest c_example c: csimpletest z: zsimpletest 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) .SUFFIXES: .c .F .o .F.o: $(FC) $(OPTF) $(INCS) -I. -I$(topdir)/include -c $*.F $(OUTF)$*.o .c.o: $(CC) $(OPTC) $(INCS) -I. -I$(topdir)/include -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 mumps-4.10.0.dfsg/examples/csimpletest.F0000644000175300017530000000330511562233011020355 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'cmumps_struc.h' TYPE (CMUMPS_STRUC) mumps_par INTEGER IERR, I 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) C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NZ ALLOCATE( mumps_par%IRN ( mumps_par%NZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NZ ) ) ALLOCATE( mumps_par%A( mumps_par%NZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I = 1, mumps_par%NZ READ(5,*) mumps_par%IRN(I),mumps_par%JCN(I),mumps_par%A(I) 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) 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) CALL MPI_FINALIZE(IERR) STOP END mumps-4.10.0.dfsg/examples/ssimpletest.F0000644000175300017530000000330511562233011020375 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'smumps_struc.h' TYPE (SMUMPS_STRUC) mumps_par INTEGER IERR, I 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) C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NZ ALLOCATE( mumps_par%IRN ( mumps_par%NZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NZ ) ) ALLOCATE( mumps_par%A( mumps_par%NZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I = 1, mumps_par%NZ READ(5,*) mumps_par%IRN(I),mumps_par%JCN(I),mumps_par%A(I) 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) 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) CALL MPI_FINALIZE(IERR) STOP END mumps-4.10.0.dfsg/examples/README0000644000175300017530000000206311562233010016571 0ustar hazelscthazelsct * 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 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) mumps-4.10.0.dfsg/examples/input_simpletest_real0000644000175300017530000000027511562233010022252 0ustar hazelscthazelsct5 :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-4.10.0.dfsg/examples/dsimpletest.F0000644000175300017530000000330511562233011020356 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'dmumps_struc.h' TYPE (DMUMPS_STRUC) mumps_par INTEGER IERR, I 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) C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NZ ALLOCATE( mumps_par%IRN ( mumps_par%NZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NZ ) ) ALLOCATE( mumps_par%A( mumps_par%NZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I = 1, mumps_par%NZ READ(5,*) mumps_par%IRN(I),mumps_par%JCN(I),mumps_par%A(I) 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) 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) CALL MPI_FINALIZE(IERR) STOP END mumps-4.10.0.dfsg/examples/c_example.c0000644000175300017530000000363011562233010020013 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * */ /* 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; int n = 2; int nz = 2; int irn[] = {1,2}; int jcn[] = {1,2}; double a[2]; double rhs[2]; int myid, ierr; #if defined(MAIN_COMP) argv = &name; #endif ierr = MPI_Init(&argc, &argv); ierr = MPI_Comm_rank(MPI_COMM_WORLD, &myid); /* Define A and rhs */ rhs[0]=1.0;rhs[1]=4.0; a[0]=1.0;a[1]=2.0; /* Initialize a MUMPS instance. Use MPI_COMM_WORLD */ id.job=JOB_INIT; id.par=1; id.sym=0;id.comm_fortran=USE_COMM_WORLD; dmumps_c(&id); /* Define the problem on the host */ if (myid == 0) { id.n = n; id.nz =nz; 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. */ id.job=6; dmumps_c(&id); id.job=JOB_END; dmumps_c(&id); /* Terminate instance */ if (myid == 0) { printf("Solution is : (%8.2f %8.2f)\n", rhs[0],rhs[1]); } ierr = MPI_Finalize(); return 0; } mumps-4.10.0.dfsg/examples/input_simpletest_cmplx0000644000175300017530000000050211562233010022443 0ustar hazelscthazelsct5 : 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-4.10.0.dfsg/ChangeLog0000644000175300017530000004454011562233000015652 0ustar hazelscthazelsct------------- = ChangeLog = ------------- 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" no more occurs * 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 prserving 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 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-4.10.0.dfsg/PORD/0000755000175300017530000000000011562233000014635 5ustar hazelscthazelsctmumps-4.10.0.dfsg/PORD/include/0000755000175300017530000000000011562233000016260 5ustar hazelscthazelsctmumps-4.10.0.dfsg/PORD/include/macros.h0000644000175300017530000000425511562233000017723 0ustar hazelscthazelsct/***************************************************************************** / / 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((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 resettimer(var) \ var = 0; #define starttimer(var) \ var -= ((FLOAT)clock()/CLOCKS_PER_SEC); #define stoptimer(var) \ var += ((FLOAT)clock()/CLOCKS_PER_SEC); #define quit() \ exit(ERR); #ifdef PARIX #undef starttimer(var) #ifdef __EPX #define starttimer(var) \ var -= ((FLOAT)TimeNow()/CLOCK_TICK); #else #define starttimer(var) \ var -= ((FLOAT)TimeNowHigh()/CLK_TCK_HIGH); #endif #undef stoptimer(var) #ifdef __EPX #define stoptimer(var) \ var += ((FLOAT)TimeNow()/CLOCK_TICK); #else #define stoptimer(var) \ var += ((FLOAT)TimeNowHigh()/CLK_TCK_HIGH); #endif #undef quit() #define quit() \ exit(ERR); #endif mumps-4.10.0.dfsg/PORD/include/const.h0000644000175300017530000001027411562233000017563 0ustar hazelscthazelsct/***************************************************************************** / / 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-4.10.0.dfsg/PORD/include/types.h0000644000175300017530000001646511562233000017611 0ustar hazelscthazelsct/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: types.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains the fundamental data structures / ******************************************************************************/ typedef double FLOAT; typedef int options_t; typedef FLOAT timings_t; /***************************************************************************** Graph object ******************************************************************************/ typedef struct _graph { int nvtx; int nedges; int type; int totvwght; int *xadj; int *adjncy; int *vwght; } graph_t; /***************************************************************************** Graph bisection object ******************************************************************************/ typedef struct _gbisect { graph_t *G; int *color; int cwght[3]; } gbisect_t; /***************************************************************************** Domain decomposition object ******************************************************************************/ typedef struct _domdec { graph_t *G; int ndom; int domwght; int *vtype; int *color; int cwght[3]; int *map; struct _domdec *prev, *next; } domdec_t; /***************************************************************************** Bipartite graph object ******************************************************************************/ typedef struct _gbipart { graph_t *G; int nX; int nY; } gbipart_t; /***************************************************************************** Recursive nested dissection object ******************************************************************************/ typedef struct _nestdiss { graph_t *G; int *map; int depth; int nvint; int *intvertex; int *intcolor; int cwght[3]; struct _nestdiss *parent, *childB, *childW; } nestdiss_t; /***************************************************************************** Multisector object ******************************************************************************/ typedef struct _multisector { graph_t *G; int *stage; int nstages; int nnodes; int totmswght; } multisector_t; /***************************************************************************** Elimination graph object ******************************************************************************/ typedef struct _gelim { graph_t *G; int maxedges; int *len; int *elen; int *parent; int *degree; int *score; } gelim_t; /***************************************************************************** Bucket structure object ******************************************************************************/ typedef struct _bucket { int maxbin, maxitem; int offset; int nobj; int minbin; int *bin; int *next; int *last; 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; int *reachset; int nreach; int *auxaux; int *auxbin; int *auxtmp; int flag; } minprior_t; struct _stageinfo { int nstep; int welim; int nzf; FLOAT ops; }; /***************************************************************************** Elimination tree object ******************************************************************************/ typedef struct _elimtree { int nvtx; int nfronts; int root; int *ncolfactor; int *ncolupdate; int *parent; int *firstchild; int *silbings; int *vtx2front; } elimtree_t; /***************************************************************************** Input matrix object ******************************************************************************/ typedef struct _inputMtx { int neqs; int nelem; FLOAT *diag; FLOAT *nza; int *xnza; int *nzasub; } inputMtx_t; /***************************************************************************** Dense matrix object ******************************************************************************/ typedef struct _workspace workspace_t; typedef struct _denseMtx { workspace_t *ws; int front; int owned; int ncol; int nrow; int nelem; int nfloats; int *colind; int *rowind; int *collen; FLOAT *entries; FLOAT *mem; struct _denseMtx *prevMtx, *nextMtx; } denseMtx_t; struct _workspace { FLOAT *mem; int size; int maxsize; int incr; denseMtx_t *lastMtx; }; /***************************************************************************** Compressed subscript structure object ******************************************************************************/ typedef struct _css { int neqs; int nind; int owned; int *xnzl; int *nzlsub; int *xnzlsub; } css_t; /***************************************************************************** Front subscript object ******************************************************************************/ typedef struct _frontsub { elimtree_t *PTP; int nind; int *xnzf; int *nzfsub; } frontsub_t; /***************************************************************************** Factor matrix object ******************************************************************************/ typedef struct _factorMtx { int nelem; int *perm; FLOAT *nzl; css_t *css; frontsub_t *frontsub; } factorMtx_t; /***************************************************************************** Mapping object ******************************************************************************/ typedef struct _groupinfo groupinfo_t; typedef struct { elimtree_t *T; int dimQ; int maxgroup; int *front2group; groupinfo_t *groupinfo; } mapping_t; struct _groupinfo { FLOAT ops; int nprocs; int nfronts; }; /***************************************************************************** Topology object ******************************************************************************/ typedef struct { int nprocs; int mygridId; int dimX; int dimY; int myQId; int dimQ; 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 { int dimQ; int maxgroup; int mygroupId; int offset; int *group; int *colbits, *colmask; int *rowbits, *rowmask; } mask_t; mumps-4.10.0.dfsg/PORD/include/protos.h0000644000175300017530000003006011562233000017756 0ustar hazelscthazelsct/***************************************************************************** / / 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 */ int greg_pord(int, int, int *, int *, int *, int *, int *); /* functions in lib/graph.c */ graph_t* newGraph(int, int); void freeGraph(graph_t*); void printGraph(graph_t*); void randomizeGraph(graph_t*); graph_t* setupSubgraph(graph_t*, int*, int, int*); graph_t* setupGraphFromMtx(inputMtx_t*); graph_t* setupGridGraph(int, int, int); int connectedComponents(graph_t*); graph_t* compressGraph(graph_t*, 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*); int smoothBy2Layers(gbisect_t*, int*, int*, int, int); void smoothSeparator(gbisect_t*, options_t*); /* functions in lib/ddcreate.c */ domdec_t* newDomainDecomposition(int, int); void freeDomainDecomposition(domdec_t*); void printDomainDecomposition(domdec_t*); void checkDomainDecomposition(domdec_t*); void buildInitialDomains(graph_t*, int*, int*, int*); void mergeMultisecs(graph_t *G, int*, int*); domdec_t* initialDomainDecomposition(graph_t*, int*, int*, int*); domdec_t* constructDomainDecomposition(graph_t*, int*); void computePriorities(domdec_t*, int*, int*, int); void eliminateMultisecs(domdec_t*, int*, int*); void findIndMultisecs(domdec_t*, int*, int*); domdec_t* coarserDomainDecomposition(domdec_t*, int*); void shrinkDomainDecomposition(domdec_t*, int); /* functions in lib/ddbisect.c */ void checkDDSep(domdec_t*); int findPseudoPeripheralDomain(domdec_t*, int); void constructLevelSep(domdec_t*, int); void initialDDSep(domdec_t*); void updateB2W(bucket_t*, bucket_t*, domdec_t*, int, int*, int*, int*, int*); void updateW2B(bucket_t*, bucket_t*, domdec_t*, int, int*, int*, int*, int*); void improveDDSep(domdec_t*); /* functions in lib/gbipart.c */ gbipart_t* newBipartiteGraph(int, int, int); void freeBipartiteGraph(gbipart_t*); void printGbipart(gbipart_t*); gbipart_t* setupBipartiteGraph(graph_t*, int*, int, int, int*); void maximumMatching(gbipart_t*, int*); void maximumFlow(gbipart_t*, int*, int*); void DMviaMatching(gbipart_t*, int*, int*, int*); void DMviaFlow(gbipart_t*, int*, int*, int*, int*); /* functions in lib/nestdiss.c */ nestdiss_t* newNDnode(graph_t*, int*, int); void freeNDnode(nestdiss_t*); nestdiss_t* setupNDroot(graph_t*, 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(int, int); void freeElimGraph(gelim_t*); void printElimGraph(gelim_t*); gelim_t* setupElimGraph(graph_t*); int crunchElimGraph(gelim_t*); void buildElement(gelim_t *Gelim, int me); void updateAdjncy(gelim_t*, int*, int, int*, int*); void findIndNodes(gelim_t*, int*, int, int*, int*, int*, int*); void updateDegree(gelim_t*, int*, int, int*); void updateScore(gelim_t*, int*, int, int, int*); elimtree_t* extractElimTree(gelim_t*); /* functions in lib/bucket.c */ bucket_t* newBucket(int, int, int); void freeBucket(bucket_t*); bucket_t* setupBucket(int, int, int); int minBucket(bucket_t*); void insertBucket(bucket_t*, int, int); void removeBucket(bucket_t*, int); /* functions in lib/minpriority.c */ minprior_t* newMinPriority(int nvtx, int nstages); void freeMinPriority(minprior_t*); minprior_t* setupMinPriority(multisector_t*); elimtree_t* orderMinPriority(minprior_t*, options_t*, timings_t*); void eliminateStage(minprior_t*, int, int, timings_t*); int eliminateStep(minprior_t*, int, int); /* functions in lib/tree.c */ elimtree_t* newElimTree(int, int); void freeElimTree(elimtree_t*); void printElimTree(elimtree_t *); int firstPostorder(elimtree_t*); int firstPostorder2(elimtree_t*, int); int nextPostorder(elimtree_t*, int); int firstPreorder(elimtree_t*); int nextPreorder(elimtree_t*, int); elimtree_t* setupElimTree(graph_t*, int*, int*); void initFchSilbRoot(elimtree_t*); void permFromElimTree(elimtree_t*, int*); elimtree_t* expandElimTree(elimtree_t*, int*, int); elimtree_t* permuteElimTree(elimtree_t*, int*); elimtree_t* fundamentalFronts(elimtree_t*); elimtree_t* mergeFronts(elimtree_t*, int); elimtree_t* compressElimTree(elimtree_t*, int*, int); int justifyFronts(elimtree_t*); int nWorkspace(elimtree_t*); int nFactorIndices(elimtree_t*); 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(int, int); void freeInputMtx(inputMtx_t*); void printInputMtx(inputMtx_t*); denseMtx_t* newDenseMtx(workspace_t*, int); void freeDenseMtx(denseMtx_t*); void printDenseMtx(denseMtx_t*); void checkDenseMtx(denseMtx_t*); workspace_t* initWorkspaceForDenseMtx(int, int); FLOAT* getWorkspaceForDenseMtx(workspace_t*, int); void freeWorkspaceForDenseMtx(workspace_t*); inputMtx_t* setupInputMtxFromGraph(graph_t*); inputMtx_t* setupLaplaceMtx(int, int, int); inputMtx_t* permuteInputMtx(inputMtx_t*, int*); /* functions in lib/symbfac.c */ css_t* newCSS(int, int, int); void freeCSS(css_t*); css_t* setupCSSFromGraph(graph_t*, int*, 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(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*, int); void initLocalIndices(denseMtx_t*, int*, int*); denseMtx_t* extendedAdd(denseMtx_t*, denseMtx_t*, int*, int*); denseMtx_t* setupUpdateMtxFromFrontalMtx(denseMtx_t*, factorMtx_t*); /* functions in lib/kernel.c */ denseMtx_t* factorize1x1Kernel(denseMtx_t*, int); denseMtx_t* factorize2x2Kernel(denseMtx_t*, int); denseMtx_t* factorize3x3Kernel(denseMtx_t*, 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*, int); void freeMapping(mapping_t*); void printMapping(mapping_t*); void listing(mapping_t*, int, int, int, FLOAT*, FLOAT*); mapping_t* setupMapping(elimtree_t*, int, int); void split(mapping_t*, int, int, int, int*, int*, FLOAT*, int); /* functions in lib/interface.c */ elimtree_t* SPACE_ordering(graph_t*, options_t*, timings_t*); elimtree_t* SPACE_transformElimTree(elimtree_t*, 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*, int*, FLOAT*, FLOAT*, options_t*, timings_t*); mapping_t* SPACE_mapping(graph_t*, int*, options_t*, timings_t*); /* functions in lib/sort.c */ void insertUpInts(int, int*); void insertUpIntsWithStaticIntKeys(int, int*, int*); void insertDownIntsWithStaticFloatKeys(int, int*, FLOAT*); void insertUpFloatsWithIntKeys(int, FLOAT*, int*); void qsortUpInts(int, int*, int*); void qsortUpFloatsWithIntKeys(int, FLOAT*, int*, int*); void distributionCounting(int, int*, int*); /* functions in lib/read.c */ graph_t* readChacoGraph(char*); inputMtx_t* readHarwellBoeingMtx(char*); /* functions in libPAR/topology.c */ topology_t* newTopology(int); void freeTopology(topology_t*); void printTopology(topology_t*); topology_t* setupTopology(void); void recMapCube(topology_t*, int, int, int, int, int, int); void sendCube(topology_t*, void*, size_t, int); size_t recvCube(topology_t*, void*, size_t, int); int myrank(void); /* functions in libPAR/mask.c */ mask_t* newMask(int); void freeMask(mask_t*); mask_t* setupMask(int, int, 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*, int); buffer_t* setupSymbFacBuffer(frontsub_t*, int*); void readoutSymbFacBuffer(buffer_t*, frontsub_t*, int*); buffer_t* setupNumFacBuffer(workspace_t*, mask_t*, int); void readoutNumFacBuffer(workspace_t*, buffer_t*, denseMtx_t**); buffer_t* setupTriangularBuffer(frontsub_t*, int*, FLOAT*); void readoutTriangularBuffer(buffer_t*, frontsub_t*, 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*, int msglvl, timings_t*); denseMtx_t* setupFrontalMtxPAR(mask_t*, int, workspace_t*, factorMtx_t*, int); void initLocalIndicesPAR(denseMtx_t*, int*, int*); denseMtx_t* extendedAddPAR(denseMtx_t*, denseMtx_t*, int*, int*); denseMtx_t* setupUpdateMtxFromFrontalMtxPAR(denseMtx_t*, factorMtx_t*); denseMtx_t* setupUpdateMtxFromBuffer(workspace_t*, FLOAT*); void splitDenseMtxColumnWise(denseMtx_t*, mask_t*, buffer_t*, int); void splitDenseMtxRowWise(denseMtx_t*, mask_t*, buffer_t*, int); /* functions in libPAR/kernelPAR.c */ denseMtx_t* factorize1x1KernelPAR(topology_t*, mask_t*, int, denseMtx_t*, frontsub_t*, timings_t*); denseMtx_t* factorize2x2KernelPAR(topology_t*, mask_t*, int, denseMtx_t*, frontsub_t*, timings_t*); denseMtx_t* factorize3x3KernelPAR(topology_t*, mask_t*, 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*, int, int, factorMtx_t*, FLOAT*, FLOAT*); void backwardSubst1x1KernelPAR(topology_t*, mask_t*, int, 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*, 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*, 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, int *perm, FLOAT *rhs, FLOAT *xvec, options_t *options, timings_t *cpus); mumps-4.10.0.dfsg/PORD/include/params.h0000644000175300017530000000157011562233000017717 0ustar hazelscthazelsct/***************************************************************************** / / 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-4.10.0.dfsg/PORD/include/eval.h0000644000175300017530000000427111562233000017364 0ustar hazelscthazelsct/***************************************************************************** / / 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-4.10.0.dfsg/PORD/include/space.h0000644000175300017530000000276411562233000017535 0ustar hazelscthazelsct/***************************************************************************** / / 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-4.10.0.dfsg/PORD/lib/0000755000175300017530000000000011562233000015403 5ustar hazelscthazelsctmumps-4.10.0.dfsg/PORD/lib/symbfac.c0000644000175300017530000004417711562233000017210 0ustar hazelscthazelsct/***************************************************************************** / / 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(int neqs, int nind, int owned) { css_t *css; mymalloc(css, 1, css_t); mymalloc(css->xnzl, (neqs+1), int); mymalloc(css->xnzlsub, neqs, int); if (owned) { mymalloc(css->nzlsub, nind, 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, int *perm, int *invp) { css_t *css; int *marker, *mergelink, *indices, *tmp, *xnzl, *xnzlsub, *nzlsub; int neqs, maxmem, u, v, col, mergecol, knz, mrk, beg, end; int fast, len, k, p, e, i, istart, istop; neqs = G->nvtx; maxmem = 2 * neqs; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(marker, neqs, int); mymalloc(indices, neqs, int); mymalloc(mergelink, neqs, int); mymalloc(tmp, neqs, 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, 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, int); css->nzlsub = nzlsub; return(css); } /***************************************************************************** ******************************************************************************/ css_t* setupCSSFromFrontSubscripts(frontsub_t *frontsub) { elimtree_t *PTP; css_t *css; int *xnzf, *nzfsub, *ncolfactor, *xnzl, *xnzlsub; 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; int nfronts, nind; nfronts = PTP->nfronts; nind = nFactorIndices(PTP); mymalloc(frontsub, 1, frontsub_t); mymalloc(frontsub->xnzf, (nfronts+1), int); mymalloc(frontsub->nzfsub, nind, 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; int *xnzf, *nzfsub, *ncolfactor, *ncolupdate, *parent; 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; int *ncolfactor, *ncolupdate, *firstchild, *silbings, *vtx2front; int *xnza, *nzasub, *xnzf, *nzfsub; int *marker, *tmp, *first, *indices; int nvtx, nfronts, col, firstcol, knz; 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, int); mymalloc(tmp, nvtx, int); mymalloc(first, nfronts, 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(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; int *xnzl, *nzlsub, *xnzlsub; 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; int *ncolfactor; FLOAT *nzl, *nza, *diag; int *xnzl, *nzlsub, *xnzlsub, *xnza, *nzasub, *xnzf, *nzfsub; int nelem, K, k, kstart, h, hstart, dis, i, istart, istop; 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; int *ncolfactor; FLOAT *nzl, *nza, *diag, *entriesL; int *xnzl, *xnza, *nzasub, *xnzf, *nzfsub; int *tmp, neqs, nelem, K, k, len, row, i, istart, istop; 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, 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-4.10.0.dfsg/PORD/lib/Makefile0000644000175300017530000000131211562233000017040 0ustar hazelscthazelsct # To compile directly, uncomment the line below. # include ../Make.in # # 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. .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-4.10.0.dfsg/PORD/lib/tree.c0000644000175300017530000007546611562233000016530 0ustar hazelscthazelsct/***************************************************************************** / / 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(int nvtx, int nfronts) { elimtree_t *T; mymalloc(T, 1, elimtree_t); mymalloc(T->ncolfactor, nfronts, int); mymalloc(T->ncolupdate, nfronts, int); mymalloc(T->parent, nfronts, int); mymalloc(T->firstchild, nfronts, int); mymalloc(T->silbings, nfronts, int); mymalloc(T->vtx2front, nvtx, 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) { int *ncolfactor, *ncolupdate, *parent, *firstchild, *silbings, *vtx2front; 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, int); mymalloc(link, nvtx, 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); } /***************************************************************************** ******************************************************************************/ int firstPostorder(elimtree_t *T) { int *firstchild, J; firstchild = T->firstchild; if ((J = T->root) != -1) while (firstchild[J] != -1) J = firstchild[J]; return(J); } /***************************************************************************** ******************************************************************************/ int firstPostorder2(elimtree_t *T, int root) { int *firstchild, J; firstchild = T->firstchild; if ((J = root) != -1) while (firstchild[J] != -1) J = firstchild[J]; return(J); } /***************************************************************************** ******************************************************************************/ int nextPostorder(elimtree_t *T, int J) { 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); } /***************************************************************************** ******************************************************************************/ int firstPreorder(elimtree_t *T) { return(T->root); } /***************************************************************************** ******************************************************************************/ int nextPreorder(elimtree_t *T, int J) { 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, int *perm, int *invp) { elimtree_t *T; css_t *css; int *xadj, *adjncy, *vwght, *ncolfactor, *ncolupdate, *parent; int *vtx2front, *realroot, *uf_father, *uf_size; int *xnzl, *nzlsub, *xnzlsub; int nvtx, front, front2, froot, f, r, u, v, i, istart, istop; 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, int); mymalloc(uf_father, nvtx, int); mymalloc(uf_size, nvtx, 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) { 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, int *perm) { int *vtx2front, *first, *link; 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, int); mymalloc(link, nvtx, 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, int *perm) { elimtree_t *PTP; 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, int *vtxmap, int nvtxorg) { elimtree_t *T2; int *vtx2front, *vtx2front2; 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; int *ncolfactor, *ncolupdate, *parent, *firstchild, *silbings; 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, 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, int maxzeros) { elimtree_t *T2; int *ncolfactor, *ncolupdate, *firstchild, *silbings; int *frontmap, *newncolfactor, *nzeros, *rep; 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, int); mymalloc(newncolfactor, nfronts, int); mymalloc(nzeros, nfronts, int); mymalloc(rep, nfronts, 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, int *frontmap, int cnfronts) { elimtree_t *T2; int *ncolfactor, *ncolupdate, *parent, *vtx2front; 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); } /***************************************************************************** ******************************************************************************/ int justifyFronts(elimtree_t *T) { int *ncolfactor, *ncolupdate, *firstchild, *silbings, *minWspace, *list; int nfronts, K, ncolfrontK, frontsizeK, wspace, child, nxtchild; 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, int); mymalloc(list, nfronts, 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); } /***************************************************************************** ******************************************************************************/ int nWorkspace(elimtree_t *T) { int *ncolfactor, *ncolupdate, *firstchild, *silbings, *minWspace; 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, 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); } /***************************************************************************** ******************************************************************************/ int nFactorIndices(elimtree_t *T) { int *ncolfactor, *ncolupdate; 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); } /***************************************************************************** ******************************************************************************/ int nFactorEntries(elimtree_t *T) { int *ncolfactor, *ncolupdate; 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) { int *ncolfactor, *ncolupdate; FLOAT ops, tri, rec; 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) { int *ncolfactor, *ncolupdate; FLOAT tri, rec; 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) { int *ncolfactor, *ncolupdate; FLOAT ops, tri, rec; 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-4.10.0.dfsg/PORD/lib/minpriority.c0000644000175300017530000004126611562233000020145 0ustar hazelscthazelsct/***************************************************************************** / / 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(int nvtx, 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, int); mymalloc(minprior->auxaux, nvtx, int); mymalloc(minprior->auxbin, nvtx, int); mymalloc(minprior->auxtmp, nvtx, 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; int *auxbin, *auxtmp; 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; 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, int istage, int scoretype, timings_t *cpus) { gelim_t *Gelim; bucket_t *bucket; stageinfo_t *stageinfo; int *stage, *reachset, *auxbin, *auxtmp, *auxaux; int *degree, *score; 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 ---------------------------------------------------------------- */ starttimer(cpus[TIME_UPDSCORE]); updateDegree(Gelim, reachset, nreach, auxbin); updateScore(Gelim, reachset, nreach, scoretype, auxbin); 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 ---------------------------------------------------------- */ starttimer(cpus[TIME_UPDADJNCY]); updateAdjncy(Gelim, reachset, nreach, auxtmp, pflag); stoptimer(cpus[TIME_UPDADJNCY]); /* ---------------------------------------- find indistinguishable nodes in reachset ---------------------------------------- */ starttimer(cpus[TIME_FINDINODES]); findIndNodes(Gelim, reachset, nreach, auxbin, auxaux, auxtmp, pflag); 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 --------------------------------------------------- */ starttimer(cpus[TIME_UPDSCORE]); updateDegree(Gelim, reachset, nreach, auxbin); updateScore(Gelim, reachset, nreach, scoretype, auxbin); 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++; } } /***************************************************************************** ******************************************************************************/ int eliminateStep(minprior_t *minprior, int istage, int scoretype) { gelim_t *Gelim; bucket_t *bucket; stageinfo_t *stageinfo; int *stage, *reachset, *auxtmp; int *xadj, *adjncy, *vwght, *len, *degree, *score; 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 += (int)((tri * (tri+1)) / 2); stageinfo->nzf += (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-4.10.0.dfsg/PORD/lib/bucket.c0000644000175300017530000001772711562233000017042 0ustar hazelscthazelsct/***************************************************************************** / / 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(int maxbin, int maxitem, int offset) { bucket_t *bucket; mymalloc(bucket, 1, bucket_t); mymalloc(bucket->bin, (maxbin+1), int); mymalloc(bucket->next, (maxitem+1), int); mymalloc(bucket->last, (maxitem+1), int); mymalloc(bucket->key, (maxitem+1), 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(int maxbin, int maxitem, int offset) { bucket_t *bucket; 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); } /****************************************************************************** ******************************************************************************/ int minBucket(bucket_t *bucket) { int *bin, *next, *key, maxbin, minbin, nobj; 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, int k, int item) { 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, int item) { 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-4.10.0.dfsg/PORD/lib/gbisect.c0000644000175300017530000004231411562233000017173 0ustar hazelscthazelsct/***************************************************************************** / / 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, 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; 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) { int *xadj, *adjncy, *vwght, *color, *cwght; 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; 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, int); /* -------------------------------------- construct initial domain decomposition -------------------------------------- */ 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); stoptimer(cpus[TIME_INITDOMDEC]); /* --------------------------------------------------- construct sequence of coarser domain decompositions --------------------------------------------------- */ 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); } stoptimer(cpus[TIME_COARSEDOMDEC]); /* ----------------------------------------------- determine coloring of last domain decomposition ------------------------------------------------ */ 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])); stoptimer(cpus[TIME_INITSEP]); /* -------------- refine coloring --------------- */ 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])); } 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); } /***************************************************************************** ******************************************************************************/ int smoothBy2Layers(gbisect_t *Gbisect, int *bipartvertex, int *pnX, int black, int white) { gbipart_t *Gbipart; int *xadj, *adjncy, *color, *cwght, *map; int *flow, *rc, *matching, *dmflag, dmwght[6]; 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, 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), int); switch(Gbipart->G->type) { case UNWEIGHTED: mymalloc(matching, (nX+nY), int); maximumMatching(Gbipart, matching); DMviaMatching(Gbipart, matching, dmflag, dmwght); free(matching); break; case WEIGHTED: mymalloc(flow, Gbipart->G->nedges, int); mymalloc(rc, (nX+nY), 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) { int *xadj, *adjncy, *vwght, *color, *cwght, *bipartvertex; 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, 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-4.10.0.dfsg/PORD/lib/graph.c0000644000175300017530000004003711562233000016654 0ustar hazelscthazelsct/***************************************************************************** / / 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(int nvtx, int nedges) { graph_t *G; int i; mymalloc(G, 1, graph_t); mymalloc(G->xadj, (nvtx+1), int); mymalloc(G->adjncy, nedges, int); mymalloc(G->vwght, nvtx, 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) { 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) { 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, int *intvertex, int nvint, int *vtxmap) { graph_t *Gsub; int *xadj, *adjncy, *vwght, *xadjGsub, *adjncyGsub, *vwghtGsub; 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; int *xnza, *nzasub, *xadj, *adjncy; 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(int dimX, int dimY, int type) { graph_t *G; 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); } /***************************************************************************** ******************************************************************************/ int connectedComponents(graph_t *G) { int *xadj, *adjncy, *marker, *queue; 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, int); mymalloc(queue, nvtx, 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 int indNodes(graph_t *G, int *vtxmap) { int *xadj, *adjncy, *deg, *checksum, *tmp; 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, int); mymalloc(checksum, nvtx, int); mymalloc(tmp, nvtx, 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, int* vtxmap) { graph_t *Gc; int *xadj, *adjncy, *vwght, *xadjGc, *adjncyGc, *vwghtGc, *perm; 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, 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-4.10.0.dfsg/PORD/lib/gelim.c0000644000175300017530000011736511562233000016661 0ustar hazelscthazelsct/***************************************************************************** / / 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(int nvtx, int nedges) { gelim_t *Gelim; mymalloc(Gelim, 1, gelim_t); Gelim->G = newGraph(nvtx, nedges); Gelim->maxedges = nedges; mymalloc(Gelim->len, nvtx, int); mymalloc(Gelim->elen, nvtx, int); mymalloc(Gelim->parent, nvtx, int); mymalloc(Gelim->degree, nvtx, int); mymalloc(Gelim->score, nvtx, 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; 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; int *xadj, *adjncy, *vwght, *xadjGelim, *adjncyGelim, *vwghtGelim; int *len, *elen, *parent, *degree, *score; 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); } /***************************************************************************** ******************************************************************************/ int crunchElimGraph(gelim_t *Gelim) { int *xadj, *adjncy, *len; 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, int me) { graph_t *G; int *xadj, *adjncy, *vwght, *len, *elen, *parent, *degree, *score; int degme, elenme, vlenme, mesrcptr, medeststart, medeststart2; 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, int *reachset, int nreach, int *tmp, int *pflag) { int *xadj, *adjncy, *vwght, *len, *elen, *parent, *score; int u, v, e, me, i, j, jj, jdest, jfirstolde, jfirstv, jstart, jstop; 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, int *reachset, int nreach, int *bin, int *next, int *tmp, int *pflag) { int *xadj, *adjncy, *vwght, *len, *elen, *parent, *score; 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, int *reachset, int nreach, int *bin) { int *xadj, *adjncy, *vwght, *len, *elen, *degree; int totvwght, deg, vwghtv, u, v, w, e, me, r, i, istart, istop; 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, int *reachset, int nreach, int scoretype, int *bin) { int *xadj, *adjncy, *vwght, *len, *elen, *degree, *score; 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; 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] = (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; int *vwght, *par, *degree, *score, *sib, *fch; int *ncolfactor, *ncolupdate, *parent, *vtx2front; 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, int); mymalloc(fch, nvtx, 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-4.10.0.dfsg/PORD/lib/interface.c0000644000175300017530000006425511562233000017523 0ustar hazelscthazelsct/***************************************************************************** / / 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 }; int *vtxmap, istage, totnstep, totnzf; FLOAT totops; /* -------------------------------------------------- set default options, if no other options specified -------------------------------------------------- */ if (options == NULL) options = default_options; /* ---------------- reset all timers ---------------- */ resettimer(cpusOrd[TIME_COMPRESS]); resettimer(cpusOrd[TIME_MS]); resettimer(cpusOrd[TIME_MULTILEVEL]); resettimer(cpusOrd[TIME_INITDOMDEC]); resettimer(cpusOrd[TIME_COARSEDOMDEC]); resettimer(cpusOrd[TIME_INITSEP]); resettimer(cpusOrd[TIME_REFINESEP]); resettimer(cpusOrd[TIME_SMOOTH]); resettimer(cpusOrd[TIME_BOTTOMUP]); resettimer(cpusOrd[TIME_UPDADJNCY]); resettimer(cpusOrd[TIME_FINDINODES]); resettimer(cpusOrd[TIME_UPDSCORE]); /* ------------------ compress the graph ------------------ */ starttimer(cpusOrd[TIME_COMPRESS]); mymalloc(vtxmap, G->nvtx, int); Gc = compressGraph(G, vtxmap); 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 ------------------- */ starttimer(cpusOrd[TIME_MS]); ms = constructMultisector(Gc, options, cpusOrd); 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 --------------------------------- */ starttimer(cpusOrd[TIME_BOTTOMUP]) minprior = setupMinPriority(ms); T = orderMinPriority(minprior, options, cpusOrd); 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, 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; int *perm, neqs, nelem; /* ------------------------------------------------------ extract permutation vectors from T and permute T and A ------------------------------------------------------ */ neqs = A->neqs; mymalloc(perm, neqs, 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 ---------------- */ resettimer(cpusFactor[TIME_INITFRONT]); resettimer(cpusFactor[TIME_EXADD]); resettimer(cpusFactor[TIME_KERNEL]); 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; int *perm; 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 ---------------- */ resettimer(t_graph); resettimer(t_ord); resettimer(t_etree); resettimer(t_symb); resettimer(t_num); resettimer(t_solvetri); /* ----------------- set up graph G(A) ----------------- */ starttimer(t_graph); G = setupGraphFromMtx(A); 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) -------------------------------------------- */ starttimer(t_ord); T = SPACE_ordering(G, options, cpusOrd); 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 ------------------------------- */ starttimer(t_etree); T2 = SPACE_transformElimTree(T, options[OPTION_ETREE_NONZ]); 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 ------------------------ */ starttimer(t_symb); L = SPACE_symbFac(T2, A); 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 ----------------------- */ starttimer(t_num); SPACE_numFac(L, cpusFactor); 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 ------------------------------ */ starttimer(t_solvetri); SPACE_solveTriangular(L, rhs, xvec); 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, 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 }; 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 ---------------- */ resettimer(t_graph); resettimer(t_etree_construct); resettimer(t_etree_merge); resettimer(t_symb); resettimer(t_num); resettimer(t_solvetri); /* ----------------- set up graph G(A) ----------------- */ starttimer(t_graph); G = setupGraphFromMtx(A); 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 --------------------------------------------------- */ starttimer(t_etree_construct); mymalloc(invp, G->nvtx, int); for (i = 0; i < G->nvtx; i++) invp[perm[i]] = i; T = setupElimTree(G, perm, invp); 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 ------------------------------- */ starttimer(t_etree_merge); T2 = SPACE_transformElimTree(T, maxzeros); 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 ------------------------ */ starttimer(t_symb); L = SPACE_symbFac(T2, A); 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 ----------------------- */ starttimer(t_num); SPACE_numFac(L, cpusFactor); 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 ------------------------------ */ starttimer(t_solvetri); SPACE_solveTriangular(L, rhs, xvec); 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, 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 }; 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 ---------------- */ resettimer(t_etree_construct); resettimer(t_etree_merge); resettimer(t_map); /* --------------------------------------------------- construct inital elimination tree according to perm --------------------------------------------------- */ starttimer(t_etree_construct); mymalloc(invp, G->nvtx, int); for (i = 0; i < G->nvtx; i++) invp[perm[i]] = i; T = setupElimTree(G, perm, invp); 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 ------------------------------- */ starttimer(t_etree_merge); T2 = SPACE_transformElimTree(T, maxzeros); 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 ------------------- */ starttimer(t_map); map = setupMapping(T2, dimQ, bal); 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-4.10.0.dfsg/PORD/lib/sort.c0000644000175300017530000001364611562233000016550 0ustar hazelscthazelsct/***************************************************************************** / / 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(int n, int *array) { 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(int n, int *array, int *key) { int i, j, ke; 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(int n, int *array, FLOAT *key) { 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(int n, FLOAT *array, int *key) { 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(int n, int *array, int *stack) { register int i, j; 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(int n, FLOAT *array, int *key, int *stack) { register int i, j; 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(int n, int *node, int *key) { register int i; 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), int); mymalloc(tmp, n, 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-4.10.0.dfsg/PORD/lib/multisector.c0000644000175300017530000002646111562233000020132 0ustar hazelscthazelsct/***************************************************************************** / / 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, 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; 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; 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, 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; int *stage, *intvertex, *intcolor; 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; int *stage, *intvertex, *intcolor; 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-4.10.0.dfsg/PORD/lib/nestdiss.c0000644000175300017530000002521111562233000017404 0ustar hazelscthazelsct/***************************************************************************** / / 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, int *map, int nvint) { nestdiss_t *nd; mymalloc(nd, 1, nestdiss_t); mymalloc(nd->intvertex, nvint, int); mymalloc(nd->intcolor, nvint, 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, int *map) { nestdiss_t *ndroot; 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; int *map, *intvertex, *intcolor, *b_intvertex, *w_intvertex; 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 --------------------------------- */ starttimer(cpus[TIME_MULTILEVEL]); constructSeparator(Gbisect, options, cpus); stoptimer(cpus[TIME_MULTILEVEL]); starttimer(cpus[TIME_SMOOTH]); if (Gbisect->cwght[GRAY] > 0) smoothSeparator(Gbisect, options); 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]; 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-4.10.0.dfsg/PORD/lib/ddcreate.c0000644000175300017530000007375711562233000017345 0ustar hazelscthazelsct/***************************************************************************** / / 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(int nvtx, int nedges) { domdec_t *dd; mymalloc(dd, 1, domdec_t); mymalloc(dd->vtype, nvtx, int); mymalloc(dd->color, nvtx, int); mymalloc(dd->map, nvtx, 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; 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) { int *xadj, *adjncy, *vwght, *vtype; 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, int *vtxlist, int *vtype, int *rep) { int *xadj, *adjncy; 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, int *vtype, int *rep) { int *xadj, *adjncy, *tmp, *queue; int nvtx, qhead, qtail, flag, keepon, u, v, w, x; int i, istart, istop, j, jstart, jstop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, nvtx, int); mymalloc(queue, nvtx, 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, int *map, int *vtype, int *rep) { domdec_t *dd; int *xadj, *adjncy, *vwght, *xadjdd, *adjncydd, *vwghtdd, *vtypedd; int *tmp, *bin, nvtx, nedges, nvtxdd, nedgesdd, ndom, domwght, flag; 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, int); mymalloc(bin, nvtx, 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, int *map) { domdec_t *dd; int *xadj, *adjncy, *vwght, *vtxlist, *vtype, *key, *rep; 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, int); mymalloc(key, nvtx, 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, int); mymalloc(rep, nvtx, 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, int *msvtxlist, int *key, int scoretype) { int *xadj, *adjncy, *vwght, *marker; int nvtx, nlist, k, weight, deg, u, v, w; 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, int *msvtxlist, int *rep) { int *xadj, *adjncy, *vtype; 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, int *msvtxlist, int *rep) { int *xadj, *adjncy, *vtype, *tmp, *bin, *checksum, *next, *key; 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, int); mymalloc(bin, nvtx, int); mymalloc(next, nvtx, int); mymalloc(key, nvtx, 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, int *rep) { domdec_t *dd2; int *xadjdd1, *adjncydd1, *vwghtdd1, *vtypedd1, *mapdd1; int *xadjdd2, *adjncydd2, *vwghtdd2, *vtypedd2; int *tmp, *bin, nvtxdd1, nedgesdd1, nvtxdd2, nedgesdd2; 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, int); mymalloc(bin, nvtxdd1, 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, int scoretype) { domdec_t *dd2; int *msvtxlist, *rep, *key; int nvtxdd1, nlist, u; nvtxdd1 = dd1->G->nvtx; mymalloc(msvtxlist, nvtxdd1, int); mymalloc(rep, nvtxdd1, int); mymalloc(key, nvtxdd1, 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-4.10.0.dfsg/PORD/lib/ddbisect.c0000644000175300017530000007175511562233000017347 0ustar hazelscthazelsct/***************************************************************************** / / 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) { int *xadj, *adjncy, *vwght, *vtype, *color, *cwght; int nvtx, err, u, v, i, istart, istop, nBdom, nWdom; 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(); } /***************************************************************************** ******************************************************************************/ int findPseudoPeripheralDomain(domdec_t* dd, int domain) { int *xadj, *adjncy, *vtype, *level, *queue; 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, int); mymalloc(queue, nvtx, 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, int domain) { int *xadj, *adjncy, *vwght, *vtype, *color, *cwght; int *queue, *deltaS, *deltaB, *deltaW; int nvtx, bestvalue, weight, qhead, qtail, qopt, q, dS, dB, dW; 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, int); mymalloc(deltaS, nvtx, int); mymalloc(deltaB, nvtx, int); mymalloc(deltaW, nvtx, 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) { int *vtype, *color, *cwght; 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, int domain, int *tmp_color, int *deltaW, int *deltaB, int *deltaS) { int *xadj, *adjncy, *vwght, *vtype; 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, int domain, int *tmp_color, int *deltaW, int *deltaB, int *deltaS) { int *xadj, *adjncy, *vwght, *vtype; 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; int *xadj, *adjncy, *vwght, *vtype, *color, *cwght; int *tmp_color, *deltaS, *deltaB, *deltaW; int nvtx, weight, tmp_S, tmp_B, tmp_W; int pos, bestglobalpos, badflips, b_domain, w_domain, domain, nxtdomain; 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, int); mymalloc(deltaS, nvtx, int); mymalloc(deltaB, nvtx, int); mymalloc(deltaW, nvtx, 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-4.10.0.dfsg/PORD/lib/gbipart.c0000644000175300017530000005125011562233000017202 0ustar hazelscthazelsct/***************************************************************************** / / 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(int nX, int nY, 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; 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, int *bipartvertex, int nX, int nY, int *vtxmap) { gbipart_t *Gbipart; int *xadj, *adjncy, *vwght, *xadjGb, *adjncyGb, *vwghtGb; 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, int *matching) { int *xadj, *adjncy, *level, *marker, *queue, *stack; int top, top2, u, x, x2, y, y2, nX, nY, i, istart, istop; int qhead, qtail, max_level; xadj = Gbipart->G->xadj; adjncy = Gbipart->G->adjncy; nX = Gbipart->nX; nY = Gbipart->nY; mymalloc(level, (nX+nY), int); mymalloc(marker, (nX+nY), int); mymalloc(queue, nX, int); mymalloc(stack, nY, 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, int *flow, int *rc) { int *xadj, *adjncy, *vwght, *parent, *marker, *queue; int nedges, u, v, x, y, nX, nY, j, i, istart, istop; 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), int); mymalloc(marker, (nX+nY), int); mymalloc(queue, (nX+nY), 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, int *matching, int *dmflag, int *dmwght) { int *xadj, *adjncy, *vwght, *queue, qhead, qtail; 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), 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, int *flow, int *rc, int *dmflag, int *dmwght) { int *xadj, *adjncy, *vwght, *queue, qhead, qtail; 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), 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-4.10.0.dfsg/PORD/README0000644000175300017530000000101211562233000015507 0ustar hazelscthazelsctACKNOWLEDGEMENT: This directory contains an implementation of the PORD algorithm, as described in: "Towards a tighter coupling of bottom-up and top-down sparse matrix ordering methods, J. Schulze, BIT, 41:4, pp 800, 2001." It is extracted from the SPACE-1.0 package developed at the University of Paderborn by Juergen Schulze (js@juergenschulze.de). A lot of the code in SPACE-1.0 was itself based on the SPOOLES package by Cleve Ashcraft. We are grateful to Juergen Schulze for letting us distribute PORD. mumps-4.10.0.dfsg/include/0000755000175300017530000000000011562233064015526 5ustar hazelscthazelsctmumps-4.10.0.dfsg/include/dmumps_struc.h0000644000175300017530000002527111562233064020433 0ustar hazelscthazelsct! ! This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 ! ! ! This version of MUMPS is provided to you free of charge. It is public ! domain, based on public domain software developed during the Esprit IV ! European project PARASOL (1996-1999). Since this first public domain ! version in 1999, research and developments have been supported by the ! following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, ! INRIA, and University of Bordeaux. ! ! The MUMPS team at the moment of releasing this version includes ! Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, ! Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora ! Ucar and Clement Weisbecker. ! ! We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil ! Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, ! Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire ! Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who ! have been contributing to this project. ! ! Up-to-date copies of the MUMPS package 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. ! ! ! User documentation of any code that uses this software can ! include this complete notice. You can acknowledge (using ! references [1] and [2]) the contribution of this package ! in any scientific publication dependent upon the use of the ! package. You shall 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 and A. Guermouche and 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). ! 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 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, pad1 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 permutations (optionnal) ! --------------------------------------------------------- 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=14) 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 CHARACTER(LEN=5) :: 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 :: POIDS 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, PTRAR, FRTPTR, FRTELT 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, NA_ELT, pad11 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 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 DOUBLE PRECISION, DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array DOUBLE PRECISION DKEEP(30) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER ::CB_SON_SIZE, pad12 ! 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, pad13 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 CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! ------------------------ ! Root structure(internal) ! ------------------------ TYPE (DMUMPS_ROOT_STRUC) :: root END TYPE DMUMPS_STRUC mumps-4.10.0.dfsg/include/zmumps_struc.h0000644000175300017530000002525511562233064020463 0ustar hazelscthazelsct! ! This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 ! ! ! This version of MUMPS is provided to you free of charge. It is public ! domain, based on public domain software developed during the Esprit IV ! European project PARASOL (1996-1999). Since this first public domain ! version in 1999, research and developments have been supported by the ! following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, ! INRIA, and University of Bordeaux. ! ! The MUMPS team at the moment of releasing this version includes ! Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, ! Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora ! Ucar and Clement Weisbecker. ! ! We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil ! Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, ! Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire ! Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who ! have been contributing to this project. ! ! Up-to-date copies of the MUMPS package 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. ! ! ! User documentation of any code that uses this software can ! include this complete notice. You can acknowledge (using ! references [1] and [2]) the contribution of this package ! in any scientific publication dependent upon the use of the ! package. You shall 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 and A. Guermouche and 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). ! 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 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, pad1 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 permutations (optionnal) ! --------------------------------------------------------- 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=14) 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 CHARACTER(LEN=5) :: 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 :: POIDS 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, PTRAR, FRTPTR, FRTELT 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, NA_ELT, pad11 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 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 COMPLEX(kind=8), DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array DOUBLE PRECISION DKEEP(30) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER ::CB_SON_SIZE, pad12 ! 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, pad13 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 CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! ------------------------ ! Root structure(internal) ! ------------------------ TYPE (ZMUMPS_ROOT_STRUC) :: root END TYPE ZMUMPS_STRUC mumps-4.10.0.dfsg/include/mumps_c_types.h0000644000175300017530000000613011562233011020556 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #ifndef MUMPS_C_TYPES_H #define MUMPS_C_TYPES_H #define MUMPS_INT int #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 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-4.10.0.dfsg/include/dmumps_root.h0000644000175300017530000000653511562233064020260 0ustar hazelscthazelsct! ! This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 ! ! ! This version of MUMPS is provided to you free of charge. It is public ! domain, based on public domain software developed during the Esprit IV ! European project PARASOL (1996-1999). Since this first public domain ! version in 1999, research and developments have been supported by the ! following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, ! INRIA, and University of Bordeaux. ! ! The MUMPS team at the moment of releasing this version includes ! Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, ! Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora ! Ucar and Clement Weisbecker. ! ! We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil ! Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, ! Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire ! Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who ! have been contributing to this project. ! ! Up-to-date copies of the MUMPS package 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. ! ! ! User documentation of any code that uses this software can ! include this complete notice. You can acknowledge (using ! references [1] and [2]) the contribution of this package ! in any scientific publication dependent upon the use of the ! package. You shall 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 and A. Guermouche and 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). ! 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 ! END TYPE DMUMPS_ROOT_STRUC mumps-4.10.0.dfsg/include/cmumps_struc.h0000644000175300017530000002500511562233064020425 0ustar hazelscthazelsct! ! This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 ! ! ! This version of MUMPS is provided to you free of charge. It is public ! domain, based on public domain software developed during the Esprit IV ! European project PARASOL (1996-1999). Since this first public domain ! version in 1999, research and developments have been supported by the ! following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, ! INRIA, and University of Bordeaux. ! ! The MUMPS team at the moment of releasing this version includes ! Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, ! Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora ! Ucar and Clement Weisbecker. ! ! We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil ! Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, ! Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire ! Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who ! have been contributing to this project. ! ! Up-to-date copies of the MUMPS package 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. ! ! ! User documentation of any code that uses this software can ! include this complete notice. You can acknowledge (using ! references [1] and [2]) the contribution of this package ! in any scientific publication dependent upon the use of the ! package. You shall 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 and A. Guermouche and 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). ! 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 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, pad1 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 permutations (optionnal) ! --------------------------------------------------------- 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=14) 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 CHARACTER(LEN=5) :: 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 :: POIDS 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, PTRAR, FRTPTR, FRTELT 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, NA_ELT, pad11 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 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 COMPLEX, DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array REAL DKEEP(30) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER ::CB_SON_SIZE, pad12 ! 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, pad13 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 CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! ------------------------ ! Root structure(internal) ! ------------------------ TYPE (CMUMPS_ROOT_STRUC) :: root END TYPE CMUMPS_STRUC mumps-4.10.0.dfsg/include/smumps_root.h0000644000175300017530000000644111562233064020273 0ustar hazelscthazelsct! ! This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 ! ! ! This version of MUMPS is provided to you free of charge. It is public ! domain, based on public domain software developed during the Esprit IV ! European project PARASOL (1996-1999). Since this first public domain ! version in 1999, research and developments have been supported by the ! following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, ! INRIA, and University of Bordeaux. ! ! The MUMPS team at the moment of releasing this version includes ! Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, ! Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora ! Ucar and Clement Weisbecker. ! ! We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil ! Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, ! Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire ! Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who ! have been contributing to this project. ! ! Up-to-date copies of the MUMPS package 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. ! ! ! User documentation of any code that uses this software can ! include this complete notice. You can acknowledge (using ! references [1] and [2]) the contribution of this package ! in any scientific publication dependent upon the use of the ! package. You shall 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 and A. Guermouche and 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). ! 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 ! END TYPE SMUMPS_ROOT_STRUC mumps-4.10.0.dfsg/include/cmumps_root.h0000644000175300017530000000645511562233064020260 0ustar hazelscthazelsct! ! This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 ! ! ! This version of MUMPS is provided to you free of charge. It is public ! domain, based on public domain software developed during the Esprit IV ! European project PARASOL (1996-1999). Since this first public domain ! version in 1999, research and developments have been supported by the ! following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, ! INRIA, and University of Bordeaux. ! ! The MUMPS team at the moment of releasing this version includes ! Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, ! Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora ! Ucar and Clement Weisbecker. ! ! We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil ! Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, ! Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire ! Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who ! have been contributing to this project. ! ! Up-to-date copies of the MUMPS package 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. ! ! ! User documentation of any code that uses this software can ! include this complete notice. You can acknowledge (using ! references [1] and [2]) the contribution of this package ! in any scientific publication dependent upon the use of the ! package. You shall 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 and A. Guermouche and 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). ! 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 ! END TYPE CMUMPS_ROOT_STRUC mumps-4.10.0.dfsg/include/dmumps_c.h0000644000175300017530000001163511562233011017504 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ /* 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 "4.10.0" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 14 #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]; DMUMPS_REAL cntl[15]; 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_INT *irn; MUMPS_INT *jcn; DMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_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 (input only in this version) */ DMUMPS_REAL *colsca; DMUMPS_REAL *rowsca; /* 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; } DMUMPS_STRUC_C; void MUMPS_CALL dmumps_c( DMUMPS_STRUC_C * dmumps_par ); #ifdef __cplusplus } #endif #endif /* DMUMPS_C_H */ mumps-4.10.0.dfsg/include/cmumps_c.h0000644000175300017530000001163511562233011017503 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ /* 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 "4.10.0" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 14 #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]; CMUMPS_REAL cntl[15]; 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_INT *irn; MUMPS_INT *jcn; CMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_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 (input only in this version) */ CMUMPS_REAL *colsca; CMUMPS_REAL *rowsca; /* 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; } CMUMPS_STRUC_C; void MUMPS_CALL cmumps_c( CMUMPS_STRUC_C * cmumps_par ); #ifdef __cplusplus } #endif #endif /* CMUMPS_C_H */ mumps-4.10.0.dfsg/include/smumps_struc.h0000644000175300017530000002474111562233064020453 0ustar hazelscthazelsct! ! This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 ! ! ! This version of MUMPS is provided to you free of charge. It is public ! domain, based on public domain software developed during the Esprit IV ! European project PARASOL (1996-1999). Since this first public domain ! version in 1999, research and developments have been supported by the ! following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, ! INRIA, and University of Bordeaux. ! ! The MUMPS team at the moment of releasing this version includes ! Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, ! Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora ! Ucar and Clement Weisbecker. ! ! We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil ! Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, ! Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire ! Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who ! have been contributing to this project. ! ! Up-to-date copies of the MUMPS package 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. ! ! ! User documentation of any code that uses this software can ! include this complete notice. You can acknowledge (using ! references [1] and [2]) the contribution of this package ! in any scientific publication dependent upon the use of the ! package. You shall 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 and A. Guermouche and 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). ! 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 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, pad1 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 permutations (optionnal) ! --------------------------------------------------------- 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=14) 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 CHARACTER(LEN=5) :: 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 :: POIDS 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, PTRAR, FRTPTR, FRTELT 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, NA_ELT, pad11 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 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 REAL, DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array REAL DKEEP(30) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER ::CB_SON_SIZE, pad12 ! 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, pad13 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 CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! ------------------------ ! Root structure(internal) ! ------------------------ TYPE (SMUMPS_ROOT_STRUC) :: root END TYPE SMUMPS_STRUC mumps-4.10.0.dfsg/include/smumps_c.h0000644000175300017530000001163511562233011017523 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ /* 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 "4.10.0" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 14 #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]; SMUMPS_REAL cntl[15]; 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_INT *irn; MUMPS_INT *jcn; SMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_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 (input only in this version) */ SMUMPS_REAL *colsca; SMUMPS_REAL *rowsca; /* 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; } SMUMPS_STRUC_C; void MUMPS_CALL smumps_c( SMUMPS_STRUC_C * smumps_par ); #ifdef __cplusplus } #endif #endif /* SMUMPS_C_H */ mumps-4.10.0.dfsg/include/zmumps_c.h0000644000175300017530000001163511562233011017532 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ /* 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 "4.10.0" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 14 #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]; ZMUMPS_REAL cntl[15]; 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_INT *irn; MUMPS_INT *jcn; ZMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_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 (input only in this version) */ ZMUMPS_REAL *colsca; ZMUMPS_REAL *rowsca; /* 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; } ZMUMPS_STRUC_C; void MUMPS_CALL zmumps_c( ZMUMPS_STRUC_C * zmumps_par ); #ifdef __cplusplus } #endif #endif /* ZMUMPS_C_H */ mumps-4.10.0.dfsg/include/mumps_compat.h0000644000175300017530000000527711562233011020406 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ /* 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 /* 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 (__STDC_VERSION__ >= 199901L) # define MUMPS_INLINE static inline #else # define MUMPS_INLINE #endif #endif /* MUMPS_COMPAT_H */ mumps-4.10.0.dfsg/include/zmumps_root.h0000644000175300017530000000653111562233064020302 0ustar hazelscthazelsct! ! This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 ! ! ! This version of MUMPS is provided to you free of charge. It is public ! domain, based on public domain software developed during the Esprit IV ! European project PARASOL (1996-1999). Since this first public domain ! version in 1999, research and developments have been supported by the ! following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, ! INRIA, and University of Bordeaux. ! ! The MUMPS team at the moment of releasing this version includes ! Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, ! Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora ! Ucar and Clement Weisbecker. ! ! We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil ! Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, ! Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire ! Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who ! have been contributing to this project. ! ! Up-to-date copies of the MUMPS package 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. ! ! ! User documentation of any code that uses this software can ! include this complete notice. You can acknowledge (using ! references [1] and [2]) the contribution of this package ! in any scientific publication dependent upon the use of the ! package. You shall 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 and A. Guermouche and 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). ! 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 ! END TYPE ZMUMPS_ROOT_STRUC mumps-4.10.0.dfsg/lib/0000755000175300017530000000000011562233000014637 5ustar hazelscthazelsctmumps-4.10.0.dfsg/SCILAB/0000755000175300017530000000000011562233010015027 5ustar hazelscthazelsctmumps-4.10.0.dfsg/SCILAB/Help/0000755000175300017530000000000011562233010015717 5ustar hazelscthazelsctmumps-4.10.0.dfsg/SCILAB/Help/manrev.dtd0000644000175300017530000000514211562233010017706 0ustar hazelscthazelsct mumps-4.10.0.dfsg/SCILAB/Help/help_dmumps.html0000644000175300017530000001742311562233010021131 0ustar hazelscthazelsct 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.

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-4.10.0.dfsg/SCILAB/Help/help_initmumps.xml0000644000175300017530000000230211562233010021473 0ustar hazelscthazelsct 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-4.10.0.dfsg/SCILAB/Help/help_initmumps.html0000644000175300017530000000232611562233010021645 0ustar hazelscthazelsct 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-4.10.0.dfsg/SCILAB/Help/help_zmumps.xml0000644000175300017530000002054011562233010021005 0ustar hazelscthazelsct 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.
    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-4.10.0.dfsg/SCILAB/Help/help_dmumps.xml0000644000175300017530000002054011562233010020757 0ustar hazelscthazelsct 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.
    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-4.10.0.dfsg/SCILAB/Help/whatis.htm0000644000175300017530000000076311562233010017736 0ustar hazelscthazelsct 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-4.10.0.dfsg/SCILAB/Help/help_zmumps.html0000644000175300017530000001742311562233010021157 0ustar hazelscthazelsct 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.

    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-4.10.0.dfsg/SCILAB/loader.sce0000644000175300017530000000144411562233007017002 0ustar hazelscthazelsctpath= 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-4.10.0.dfsg/SCILAB/builder.sce0000644000175300017530000000524411562233010017156 0ustar hazelscthazelsct// $Id: builder_source.sce 7139 2011-03-22 22:50:47Z jylexcel $ //******************* VARIABLE PART TO COSTUMIZE ***************************// // -- MUMPS: MUMPS_DIR = home + "/MUMPS_4.10.0"; 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-4.10.0.dfsg/SCILAB/examples/0000755000175300017530000000000011562233010016645 5ustar hazelscthazelsctmumps-4.10.0.dfsg/SCILAB/examples/ex.sci0000644000175300017530000000022211562233010017755 0ustar hazelscthazelscta(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-4.10.0.dfsg/SCILAB/examples/sparseRHS_example.sce0000644000175300017530000000200211562233010022720 0ustar hazelscthazelsct//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-4.10.0.dfsg/SCILAB/examples/ex_rhs.sci0000644000175300017530000000007311562233010020635 0ustar hazelscthazelsctrhs(2,1)=3; rhs(5,1)=1; rhs(1,2)=8; rhs(2,2)=2; rhs(4,2)=3;mumps-4.10.0.dfsg/SCILAB/examples/schur_example.sce0000644000175300017530000000317511562233010022206 0ustar hazelscthazelsct//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-4.10.0.dfsg/SCILAB/examples/cmplx_example.sce0000644000175300017530000000173311562233010022203 0ustar hazelscthazelsct//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-4.10.0.dfsg/SCILAB/examples/double_example.sce0000644000175300017530000000166211562233010022333 0ustar hazelscthazelsct//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-4.10.0.dfsg/SCILAB/intmumpsc.c0000644000175300017530000005074011562233010017220 0ustar hazelscthazelsct#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. * Note that 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-4.10.0.dfsg/SCILAB/README0000644000175300017530000001105611562233007015720 0ustar hazelscthazelsctREADME ************************************************************************ * This SCILAB interface to MUMPS is provided to you free of charge. * * It is part of the MUMPS package (see ../Conditions_of_use) and is * * public domain. Up-to-date copies can be obtained from the Web * * pages http://www.enseeiht.fr/apo/MUMPS/ 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 info is available in the main MUMPS users' guide 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. * * * ************************************************************************ CONTENT 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 for Scilab: You need: 1- scilab version 3.x or 4.x (not tested with scilab 5.x) 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-4.10.0.dfsg/SCILAB/zmumps.sci0000644000175300017530000000515111562233010017064 0ustar hazelscthazelsctfunction 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-4.10.0.dfsg/SCILAB/dmumps.sci0000644000175300017530000000515111562233007017044 0ustar hazelscthazelsctfunction 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-4.10.0.dfsg/SCILAB/initmumps.sci0000644000175300017530000000071311562233007017563 0ustar hazelscthazelsctfunction 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-4.10.0.dfsg/README0000644000175300017530000002644111562233000014760 0ustar hazelscthazelsct=========================================== MUMPS version 4.10.0 =========================================== (Quick note on upgrading from a previous version: please check if Makefiles have changed (see old and new Makefiles in Make.inc/ and be aware that all codes that use MUMPS include files must be recompiled). MUMPS 4.10.0 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.enseeiht.fr/ or at http://graal.ens-lyon.fr/MUMPS For installation problems, bug reports, and to report your experience/feedback with the package, please subscribe the MUMPS Users's mailing list. This version of MUMPS is provided to you free of charge. It is public domain, based on public domain software developed during the Esprit IV European project PARASOL (1996-1999). Since this first public domain version in 1999, research and developments have been supported by the following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, INRIA, and University of Bordeaux. The MUMPS team at the moment of releasing this version includes Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora Ucar and Clement Weisbecker. We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who have been contributing to this project. Up-to-date copies of the MUMPS package 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. User documentation of any code that uses this software can include this complete notice. You can acknowledge (using references [1] and [2]) the contribution of this package in any scientific publication dependent upon the use of the package. You shall 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 and A. Guermouche and 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). Contents of the distribution : ---------------------------- ChangeLog LICENSE README VERSION Makefile Make.inc/ doc/ src/ lib/ include/ libseq/ examples/ PORD/ MATLAB/ SCILAB/ doc contains the users' guide in postscript and pdf formats. 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') 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 Pre-requisites -------------- If you only want to use the sequential version, you need to install: -> BLAS library If you want to use the parallel version, you need to install: -> MPI -> BLAS library -> BLACS library -> ScaLAPACK library For performance (time and memory issues) we also strongly recommend to install: -> SCOTCH and/or METIS for the sequential version -> PT-SCOTCH and/or ParMetis for the parallel version Installation ------------ The following steps can be applied. % tar zxvf MUMPS_4.10.0.tar.gz % cd MUMPS_4.10.0 You then need to build a file called Makefile.inc corresponding to your achitecture. Various examples are available in the directory Make.inc : 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.INTEL.SEQ : default for PC (linux, intel compiler, lam), sequential. Makefile.INTEL.PAR : default for PC (linux, intel compiler, lam), parallel. Makefile.ALPHA_linux.SEQ : default for ALPHA linux (compiler:fort), sequential. Makefile.ALPHA_linux.PAR : default for ALPHA linux (compiler:fort), parallel. Makefile.ALPHA_true64.SEQ : default for ALPHA true 64 (compiler:f90), sequential. Makefile.ALPHA_true64.PAR : default for ALPHA true 64 (compiler:f90), parallel. 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 a parallel version of MUMPS on a 64-bit IBM SP machine, copy Make.inc/Makefile.SP64.PAR into Makefile.inc % cp Make.inc/Makefile.SP64.PAR ./Makefile.inc In most cases, Makefile.inc should be adapted to fit with your architecture, libraries and compiler (see comments in the Makefile.inc.generic or Makefile.inc.generic.SEQ for details). The variables LIBBLAS (BLAS library), SCALAP (ScaLAPACK library), INCPAR (include files for MPI), LIBPAR (library files for MPI) are concerned. By default, only the double precision version of MUMPS will be installed. make will build the version for a specific arithmetic, where can be one of 'd','c','s','z'. "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 FAQ at http://graal.ens-lyon.fr/MUMPS and http://mumps.enseeiht.fr/). -DAdd_ , -DAdd__ and -DUPPER: These options are used for defining the calling convention from C to Fortran or Fortran to C. -DALLOW_NON_INIT: This option can be used to speed up the code for symmetric matrices by allowing non initialization of data area that will modified but are not significant for the computation. 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/libxmumps.a and ./lib/libmumps_common.a constitute the MUMPS library and ./include/*.h are the include files. Also, some BLAS, 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. Platform dependencies --------------------- Versions of MUMPS have been tested on CRAY, IBM, SGI, COMPAQ, and Linux systems. We could potentially generate versions for any other platform with Fortran 90, MPI, BLACS, and ScaLAPACK installed, but the code has only been tested on the above-mentionned platforms. * 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. * INTEL Compilers --------------- Some users have reported problems (wrong results) with Intel compilers version 10.x when using default compiler optimization (-O). * COMPAQ ------ The option -nopipeline is required, otherwise, the version of the compiler we have used performs software pipeline over iterations of loops with potential dependencies. Also the option -O3 should not be used on xmumps_static_mapping.F as it seems to create erroneous code. * LAM --- lam version 6.5.6 or later is required for the double complex version of MUMPS to work correctly. * MPICH ----- MUMPS has been tested and works correctly with various versions of MPICH. The double complex version does not work correctly with MPICH2 v 1.0.3, due to truncated messages when using double complex types. * CRAY ---- On the CRAY, we recommend to link with the standard BLACS library from netlib, based on MPI. We observed problems (deadlock) when using the CRAY BLACS in host-node mode or when MUMPS is used on a subcommunicator of MPI_COMM_WORLD of more than 1 processor. mumps-4.10.0.dfsg/LICENSE0000644000175300017530000000374511562233000015107 0ustar hazelscthazelsct This version of MUMPS is provided to you free of charge. It is public domain, based on public domain software developed during the Esprit IV European project PARASOL (1996-1999). Since this first public domain version in 1999, research and developments have been supported by the following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, INRIA, and University of Bordeaux. The MUMPS team at the moment of releasing this version includes Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora Ucar and Clement Weisbecker. We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who have been contributing to this project. Up-to-date copies of the MUMPS package 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. User documentation of any code that uses this software can include this complete notice. You can acknowledge (using references [1] and [2]) the contribution of this package in any scientific publication dependent upon the use of the package. You shall 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 and A. Guermouche and 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). mumps-4.10.0.dfsg/src/0000755000175300017530000000000011562233070014667 5ustar hazelscthazelsctmumps-4.10.0.dfsg/src/zmumps_part2.F0000644000175300017530000074465411562233070017465 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE ZMUMPS_152(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_729( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) ) IF (KEEP(216).eq.3) THEN SIZFR_BLOCK_EFF=SIZFR_BLOCK ELSE CALL ZMUMPS_628( 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 ENDIF MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL ZMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLU) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 IPOSSHIFT = IWPOSCB + KEEP(IXSZ) SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_729( 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) LRLUS = LRLUS + SIZFR_BLOCK_EFF CALL ZMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLU) END IF RETURN END SUBROUTINE ZMUMPS_152 SUBROUTINE ZMUMPS_144( 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) USE ZMUMPS_OOC 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), & PTRARW(LPTRAR), PTRAIW(LPTRAR), & ND( KEEP(28) ), FRERE( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) 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(max(1,KEEP(13))) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, & NBTLKJ, IBEG_BLOCK INTEGER(8) :: POSELT INTEGER NASS, NEL1, IEND, IOLDPS, dummy, allocok LOGICAL LASTBL DOUBLE PRECISION UUTEMP INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INCLUDE 'mumps_headers.h' EXTERNAL ZMUMPS_224, ZMUMPS_233, & ZMUMPS_225, ZMUMPS_232, & ZMUMPS_294, & ZMUMPS_44 LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC 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 IBEG_BLOCK=1 dummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5),NASS ) ENDIF NBTLKJ = NBOLKJ ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, & ' integers' IFLAG = -13 IERROR =NASS GO TO 490 END IF IF (KEEP(201).EQ.1) THEN CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_U 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 50 CONTINUE IBEGKJI = IBEG_BLOCK CALL ZMUMPS_224(NFRONT,NASS,IBEGKJI, NASS, IPIV, & 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) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ENDIF IF (INOPV.GE.1) THEN LASTBL = (INOPV.EQ.1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL ZMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, NFRONT, & IBEGKJI, IEND, IPIV, NASS,LASTBL, dummy, & & 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, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (INOPV.EQ.1) GO TO 500 IF (INOPV.EQ.2) THEN CALL ZMUMPS_233(IBEG_BLOCK,NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP(IXSZ)) GOTO 50 ENDIF NPVW = NPVW + 1 IF (NASS.LE.1) THEN IFINB = -1 ELSE CALL ZMUMPS_225(IBEG_BLOCK, & NFRONT, NASS, N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),KEEP(IXSZ)) ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 50 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN LASTBL = (IFINB.EQ.-1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL ZMUMPS_294(COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, NFRONT, & IBEGKJI, IEND, IPIV, NASS, LASTBL, dummy, & & 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, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (IFINB.EQ.(-1)) GOTO 500 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV CALL ZMUMPS_232(A,LA, & NFRONT,NPIV,NASS,POSELT,NBTLKJ) IF (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV TYPEFile = TYPEF_BOTH_LU LAST_CALL= .FALSE. CALL ZMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG<0) RETURN ENDIF GO TO 50 490 CONTINUE CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE DEALLOCATE( IPIV ) IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) TYPEFile = TYPEF_BOTH_LU LAST_CALL = .TRUE. CALL ZMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG<0) RETURN CALL ZMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE ZMUMPS_144 SUBROUTINE ZMUMPS_176( 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, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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(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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) 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 INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_73(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'ZMUMPS_73' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL ZMUMPS_270( 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, 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_275(PROCNODE_STEPS(STEP(IN)),SLAVEF) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL ZMUMPS_74(IN, NELIM_SENT, & PDEST, COMM, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'ZMUMPS_73' CALL MUMPS_ABORT() endif ELSE CALL ZMUMPS_271( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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 CALL ZMUMPS_626( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL ZMUMPS_152( .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_176 SUBROUTINE ZMUMPS_268(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, NBPROCFILS, & IPOOL, LPOOL, LEAF, KEEP,KEEP8, 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) 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 NBPROCFILS( 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_330 EXTERNAL MUMPS_330 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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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 + 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 ( ( KEEP(48).NE. 0 ).AND.(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_330(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_507(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE ZMUMPS_268 SUBROUTINE ZMUMPS_242(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF) USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST 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_62( DATA(1), DEST, TAG, & COMMW, IERR ) ELSE WRITE(*,*) 'Error : bad argument to ZMUMPS_242' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE ZMUMPS_242 SUBROUTINE ZMUMPS_44( MYID, SLAVEF, COMM ) INTEGER MYID, SLAVEF, COMM INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) CALL ZMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF ) RETURN END SUBROUTINE ZMUMPS_44 SUBROUTINE ZMUMPS_464( K34, K35, K16, K10 ) IMPLICIT NONE INTEGER, INTENT(OUT) :: K34, K35, K10, K16 INTEGER SIZE_INT, SIZE_REAL_OR_DOUBLE INTEGER I(2) DOUBLE PRECISION R(2) 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_464 SUBROUTINE ZMUMPS_20( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP) IMPLICIT NONE DOUBLE PRECISION DKEEP(30) DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(40), KEEP(500), SYM, PAR, NSLAVES INTEGER INFO(40), INFOG(40) INTEGER(8) KEEP8(150) INTEGER LWK_USER C Let $A_{preproc}$ be the preprocessed matrix to be factored (see 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:30) = 0.0D0 KEEP( 50 ) = SYM IF (SYM.EQ.1) THEN KEEP(50) = 2 ENDIF IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 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 KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN KEEP(46) = 1 END IF ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 ICNTL(5) = 0 IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF ICNTL(7) = 7 ICNTL(8) = 77 ICNTL(9) = 1 ICNTL(10) = 0 ICNTL(11) = 0 IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF ICNTL(13) = 0 IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ELSE IF (NSLAVES .GT. 4) THEN ICNTL(14) = 30 ELSE ICNTL(14) = 20 END IF ICNTL(15) = 0 ICNTL(16) = 0 ICNTL(17) = 0 ICNTL(18) = 0 ICNTL(19) = 0 ICNTL(20) = 0 ICNTL(21) = 0 ICNTL(22) = 0 ICNTL(23) = 0 ICNTL(24) = 0 ICNTL(27) = -8 ICNTL(28) = 1 ICNTL(29) = 0 ICNTL(39) = 1 ICNTL(40) = 0 KEEP(12) = 0 KEEP(11) = 2147483646 KEEP(24) = 18 KEEP(68) = 0 KEEP(36) = 1 KEEP(1) = 8 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 IF (NSLAVES.GE.128) KEEP(62)=200 IF (NSLAVES.GE.128) KEEP(9)=800 IF (NSLAVES.GE.256) KEEP(9)=900 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 48 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 100 IF (NSLAVES.GE.128) KEEP(62)=150 IF (NSLAVES.GE.64) KEEP(9)=800 IF (NSLAVES.GE.128) KEEP(9)=900 END IF KEEP(63) = 60 KEEP(48) = 5 KEEP(17) = 0 CALL ZMUMPS_464( KEEP(34), KEEP(35), & KEEP(16), KEEP(10) ) #if defined(SP_) KEEP( 51 ) = 70 #else KEEP( 51 ) = 48 #endif 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) = 10 KEEP(69) = 4 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 30 KEEP(79) = 0 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) = 5 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 #else KEEP(99)=4 #endif KEEP(100)=0 KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 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 IF(NSLAVES.LE.8)THEN KEEP(238)=12 ELSE KEEP(238)=7 ENDIF KEEP(234)= 1 DKEEP(3)=-5.0D0 KEEP(242) = 1 KEEP(250) = 1 RETURN END SUBROUTINE ZMUMPS_20 SUBROUTINE ZMUMPS_786(id, LP) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN IF (LP.GT.0) & write(LP,*) 'Warning KEEP(72) = 1 !!!!!!!!!! ' 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 ELSE IF (id%KEEP(72)==2) THEN IF (LP.GT.0) & write(LP,*)' OOC setting to reduce stack memory', & ' KEEP(72)=', id%KEEP(72) id%KEEP(85)=2 id%KEEP(85)=-10000 id%KEEP(62) = 10 id%KEEP(210) = 1 id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 id%KEEP(102) = 110 id%KEEP(213) = 121 END IF RETURN END SUBROUTINE ZMUMPS_786 SUBROUTINE ZMUMPS_195(N, NZ, IRN, ICN, LIW, IKEEP, PTRAR, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N,NZ,LIW,IORD,SIZE_SCHUR, NSLAVES INTEGER PTRAR(N,4), NFSIZ(N), FILS(N), FRERE(N) INTEGER IKEEP(N,3) INTEGER LISTVAR_SCHUR(SIZE_SCHUR) INTEGER INFO(40), ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) TYPE (ZMUMPS_STRUC) :: id INTEGER IRN(NZ), ICN(NZ) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER IERR INTEGER K,I,L1,L2,IWFR,NCMPA,LLIW, IN, IFSON INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER MedDens, NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: HEAD INTEGER NUMFLAG INTEGER OPT_METIS_SIZE INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS 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 EXTERNAL MUMPS_197, ZMUMPS_198, & ZMUMPS_199, ZMUMPS_351, & ZMUMPS_557, ZMUMPS_201 #if defined(OLDDFS) EXTERNAL ZMUMPS_200 #endif EXTERNAL ZMUMPS_623 EXTERNAL ZMUMPS_547, ZMUMPS_550, & ZMUMPS_556 ALLOCATE( IW ( LIW ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW RETURN ENDIF LLIW = LIW - 2*N - 1 L1 = LLIW + 1 L2 = L1 + N LP = ICNTL(1) MP = ICNTL(3) PROK = (MP.GT.0) 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, NZ, LIW, INFO(1) K = min0(10,NZ) IF (LDIAG.EQ.4) K = NZ IF (K.GT.0) WRITE (MP,99998) (IRN(I),ICN(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 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) 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 CALL ZMUMPS_623(N,NCMP,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), MedDens, NBQD, AvgDens, & LISTVAR_SCHUR, SIZE_SCHUR, & FRERE,FILS) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif CALL ZMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), MedDens, NBQD, AvgDens) #if defined(metis) || defined(parmetis) 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 ZMUMPS_701( N, KEEP(50), NSLAVES, IORD, & symmetry, MedDens, 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_195 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_195 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_556( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) ENDIF IF ( IORD .NE. 1 ) THEN IF(COMPRESS .GE. 1) THEN CALL ZMUMPS_547( & N,NZ, IRN, ICN, PIV, & NCMP, IW(1), LLIW, IW(L2),PTRAR(1,2),PTRAR, & IW(L1), FILS, IWFR, & IERROR, KEEP,KEEP8, ICNTL) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 DEALLOCATE (IW) RETURN 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 K=1,NZ J = ICN(K) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(K) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N RETURN 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 (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' CALL ZMUMPS_351 & (N,NZ,IRN, ICN, IW(1), LLIW, IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & MedDens, NBQD, AvgDens) 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 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 ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_162(N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & 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 IF(COMPRESS .EQ. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO CALL MUMPS_PORDF_WND(NCMP, IWFR-1, IW(L2), IW, & IW(L1), NCMPA, N) CALL ZMUMPS_548(NCMP,IW(L2),IW(L1),FILS) CALL ZMUMPS_549(NCMP,IW(L2),IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ELSE CALL MUMPS_PORDF(NCMP, IWFR-1, IW(L2), IW(1), & IW(L1), NCMPA) ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 RETURN ENDIF #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH(NCMP, LLIW, IW(L2), IWFR, & PTRAR(1,2), IW(1), IW(L1), IKEEP, & IKEEP(1,2), NCMPA) IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out SCTOCH, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 3 RETURN ENDIF IF (COMPRESS .EQ. 1) THEN CALL ZMUMPS_548(NCMP,IW(L2),IW(L1),FILS) CALL ZMUMPS_549(NCMP,IW(L2),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( HEAD ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 RETURN ENDIF IF(COMPRESS .GE. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO ELSE IW(L1) = -1 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_337(NCMP, NBBUCK, LLIW, IW(L2), & IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_560(NCMP, NBBUCK, LLIW, IW(L2), & IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD, & NFSIZ, FRERE) ENDIF DEALLOCATE(HEAD) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( HEAD ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N RETURN ENDIF THRESH = 1 IVersion = 2 IF(COMPRESS .EQ. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IW(L1) = -1 TOTEL = N ENDIF CALL MUMPS_421(TOTEL,IVersion, THRESH, HEAD, & NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), & IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3)) DEALLOCATE(HEAD) ELSE CALL MUMPS_197(NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL ZMUMPS_550(N,NCMP,KEEP(94),KEEP(93), & PIV,IKEEP(1,1),IKEEP(1,2)) COMPRESS = -1 ENDIF ENDIF #if defined(metis) || defined(parmetis) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS ' ENDIF 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 RETURN ENDIF OPTIONS_METIS(1) = 0 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FILS(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FILS(I) = 1 ENDDO CALL METIS_NODEWND(NCMP, IW(L2), IW(1),FILS, & NUMFLAG, OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) ELSE CALL METIS_NODEND(NCMP, IW(L2), IW(1), NUMFLAG, & OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) ENDIF DEALLOCATE (OPTIONS_METIS) IF ( COMPRESS_SCHUR ) THEN CALL ZMUMPS_622( & N, NCMP, IKEEP(1,1),IKEEP(1,2), & LISTVAR_SCHUR, SIZE_SCHUR, FILS) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL ZMUMPS_550(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) THEN IF ( COMPRESS .EQ. -1 ) THEN CALL ZMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & MedDens, NBQD, AvgDens) INFO(8) = symmetry ENDIF COMPRESS = 0 ALLOCATE( HEAD ( 2*N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 2*N RETURN 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 =.TRUE. CALL MUMPS_422(THRESH, HEAD, & N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW, & IW(L1), HEAD(N+1), & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & IKEEP(1,1), LISTVAR_SCHUR, ITEMP, AGG6) DEALLOCATE(HEAD) ELSE CALL ZMUMPS_198(N, NZ, IRN, ICN, IKEEP, IW(1), & LLIW, IW(L2), & PTRAR(1,2), IW(L1), IWFR, & INFO(1),INFO(2), KEEP(11), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 CALL ZMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & PTRAR, NCMPA, ITEMP) ELSE CALL ZMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & PTRAR, NCMPA, SIZE_SCHUR) 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_200 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else CALL ZMUMPS_557 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, PTRAR, INFO(6), FILS, FRERE, & PTRAR(1,3), NEMIN, PTRAR(1,4), KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1) #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_201(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_209( 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_510(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 IF ( huge(KEEP8(79)) / K79REF + 1_8 .GE. int(NSLAVES,8) ) THEN KEEP8(79)=huge(KEEP8(79)) ELSE KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF 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_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG,INFO(1),INFO(2)) IF (INFO(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) & .AND. (KEEP(60).EQ.0) IF (SPLITROOT) THEN CALL ZMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG,INFO(1),INFO(2)) IF (INFO(1).LT.0) RETURN 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,99986) (PTRAR(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99985) (PTRAR(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99984) (PTRAR(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 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) GOTO 90 90 CONTINUE DEALLOCATE(IW) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NZ 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)=', 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)) 99986 FORMAT ('PTRAR(.,1)=', 10I6/(12X, 10I6)) 99985 FORMAT ('PTRAR(.,2)=', 10I6/(12X, 10I6)) 99984 FORMAT ('PTRAR(.,3)=', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE ZMUMPS_195 SUBROUTINE ZMUMPS_199(N,IPE,IW, LW, IWFR, IPS, IPV, NV, FLAG, & NCMPA, SIZE_SCHUR) INTEGER N,LW,IWFR,NCMPA,SIZE_SCHUR INTEGER FLAG(N) INTEGER IPS(N), IPV(N) INTEGER IW(LW), NV(N), IPE(N) INTEGER I,J,ML,MS,ME,IP,MINJS,IE,KDUMMY,JP INTEGER LN,JP1,JS,LWFR,JP2,JE 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) GO TO 60 LN = IW(JP) DO 50 JP1=1,LN JP = JP + 1 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 - JP1 CALL ZMUMPS_194(N, IPE, IW, IP-1, 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 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min0(MINJS,IPS(JS)+0) IWFR = IWFR + 1 50 CONTINUE 60 IPE(IE) = -ME 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 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = IWFR - IP IPE(ME) = IP IWFR = IWFR + 1 100 CONTINUE IF (SIZE_SCHUR == 0) RETURN 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) GO TO 160 LN = IW(JP) 160 IPE(IE) = -IPV(N-SIZE_SCHUR+1) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = -IPV(N-SIZE_SCHUR+1) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0 NV(ME) = SIZE_SCHUR RETURN END SUBROUTINE ZMUMPS_199 SUBROUTINE ZMUMPS_198(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, IOVFLO, MP) INTEGER N,NZ,LW,IWFR,IFLAG,IERROR INTEGER PERM(N) INTEGER IQ(N) INTEGER IRN(NZ), ICN(NZ) INTEGER IPE(N), IW(LW), FLAG(N) INTEGER MP INTEGER IOVFLO INTEGER I,J,K,LBIG,L,ID,IN,LEN,JDUMMY,K1,K2 IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1,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 LBIG = 0 DO 100 I=1,N L = IQ(I) LBIG = max0(L,LBIG) IWFR = IWFR + L IPE(I) = IWFR - 1 100 CONTINUE DO 140 K=1,NZ I = -IW(K) IF (I.LE.0) GO TO 140 L = K IW(K) = 0 DO 130 ID=1,NZ J = ICN(L) IF (PERM(I).LT.PERM(J)) GO TO 110 L = IPE(J) IPE(J) = L - 1 IN = IW(L) IW(L) = I GO TO 120 110 L = IPE(I) IPE(I) = L - 1 IN = IW(L) IW(L) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1 L = K + N IWFR = L + 1 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(L) = IW(K) K = K - 1 L = L - 1 150 CONTINUE 160 IPE(J) = L L = L - 1 170 CONTINUE IF (LBIG.GE.IOVFLO) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0 180 CONTINUE GO TO 230 190 IWFR = 1 DO 220 I=1,N K1 = IPE(I) + 1 K2 = IPE(I) + IQ(I) IF (K1.LE.K2) GO TO 200 IPE(I) = 0 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = IWFR - K - 1 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM ZMUMPS_198 ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE ZMUMPS_198 SUBROUTINE ZMUMPS_194(N, IPE, IW, LW, IWFR,NCMPA) INTEGER N,LW,IWFR,NCMPA INTEGER IPE(N) INTEGER IW(LW) INTEGER I,K1,LWFR,IR,K,K2 NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0) GO TO 10 IPE(I) = IW(K1) IW(K1) = -I 10 CONTINUE IWFR = 1 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) = IPE(I) IPE(I) = IWFR K1 = K + 1 K2 = K + IW(IWFR) IWFR = IWFR + 1 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1 40 CONTINUE 50 LWFR = K2 + 1 60 CONTINUE 70 RETURN END SUBROUTINE ZMUMPS_194 #if defined(OLDDFS) SUBROUTINE ZMUMPS_200(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_200 #else SUBROUTINE ZMUMPS_557(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 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 #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 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 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 #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(20000)* & dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) & ) & / & ( dble(NV(DADI)+NODE(I))* & dble(NV(DADI)+NODE(I)) ) ACCU = ACCU + dble(CUMUL(I) ) AMALG_TO_father_OK = ( (NODE(I).LE.NEMIN).OR. & (NODE(DADI).LE.NEMIN) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( & ( dble(2*(NODE(I)))* & dble((NV(DADI)-NV(I)+NODE(I))) & ) .LT. & ( dble(NV(DADI)+NODE(I))* & dble(NV(DADI)+NODE(I))*dble(NEMIN)/dble(100) & ) & ) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU .LE. dble(NEMIN)*dble(100) ) & ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_511(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_511(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_511(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF(FLOPS_APRES .GT. FLOPS_AVANT) 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 AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) 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_557 #endif SUBROUTINE ZMUMPS_201(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 IF(NFR .NE. NELIM) 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_201 SUBROUTINE ZMUMPS_348( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(INOUT) :: 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_348 SUBROUTINE ZMUMPS_203( N, NZ, MTRANS, PERM, & id, ICNTL, INFO) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER N, NZ, LIWG INTEGER PERM(N) INTEGER MTRANS INTEGER ICNTL(40), INFO(40) INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER LS2,LSC INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) DOUBLE PRECISION CNTL64(10) INTEGER LDW, LDWMIN INTEGER MPRINT,LP, MP, IPIW, LIW, LIWMIN INTEGER JPERM INTEGER NUMNZ, I, J, JPOS, K, NZREAL INTEGER PLENR, IP, IRNW,RSPOS,CSPOS LOGICAL PROK, IDENT, DUPPLI INTEGER NZTOT, K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG 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) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = (MPRINT.GT.0) 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 .EQ. 2) THEN NZTOT = 2*NZ+N ELSE NZTOT = NZ ENDIF ZERODIAG => id%IS1(N+1:2*N) STR_KER => id%IS1(2*N+1:3*N) CALL ZMUMPS_448(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 DIAGIONAL' 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 IP = IRNW + NZTOT PLENR = IP + N + 1 IPIW = PLENR IF (MTRANSLOC.EQ.1) LIWMIN = 5*N IF (MTRANSLOC.EQ.2) LIWMIN = 4*N IF (MTRANSLOC.EQ.3) LIWMIN = 10*N + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 5*N IF (MTRANSLOC.EQ.5) LIWMIN = 5*N IF (MTRANSLOC.EQ.6) LIWMIN = 5*N + NZTOT LIW = LIWMIN LIWG = LIW + (NZTOT + N + 1) ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) GOTO 410 IF (MTRANSLOC.EQ.1) THEN LDWMIN = N+3 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max(N+NZTOT,N+3) IF (MTRANSLOC.EQ.3) LDWMIN = max(NZTOT+1,N+3) IF (MTRANSLOC.EQ.4) LDWMIN = 2*N + max(NZTOT,N+3) IF (MTRANSLOC.EQ.5) LDWMIN = 3*N + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4*N + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N IF (allocok .GT. 0 ) GOTO 430 NZREAL = 0 DO 5 J=1,N IW(PLENR+J-1) = 0 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 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 NZREAL = NZREAL + 1 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 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 NZREAL = NZREAL + 1 IF(I .NE. J) THEN IW(PLENR+I-1) = IW(PLENR+I-1) + 1 NZREAL = NZREAL + 1 ELSE IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = K 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 IW(PLENR+I-1) = IW(PLENR+I-1) + 1 NZREAL = NZREAL + 1 ENDIF ENDDO ENDIF ENDIF IW(IP) = 1 DO 20 J=1,N IW(IP+J) = IW(IP+J-1)+IW(PLENR+J-1) 20 CONTINUE DO 25 J=1, N IW(PLENR+J-1 ) = IW(IP+J-1 ) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO 30 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I IW(PLENR+J-1) = IW(PLENR+J-1) + 1 ENDIF 30 CONTINUE ELSE IF ( .not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO 35 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I S2(JPOS) = abs(id%A(K)) IW(PLENR+J-1) = IW(PLENR+J-1) + 1 ENDIF 35 CONTINUE 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I IW(PLENR+J-1) = IW(PLENR+J-1) + 1 IF(I.NE.J) THEN JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = J IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF K = 1 THEMIN = ZERO DO IF(THEMIN .NE. ZERO) EXIT THEMIN = abs(id%A(K)) K = K+1 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I S2(JPOS) = abs(id%A(K)) IW(PLENR+J-1) = IW(PLENR+J-1) + 1 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 JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = J S2(JPOS) = abs(id%A(K)) IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = I S2(JPOS) = ZERO IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDDO CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N)) & - log(THEMIN) + ONE ENDIF ENDIF DUPPLI = .FALSE. I = NZREAL FLAG => id%IS1(3*N+1:4*N) IF(MTRANSLOC.NE.1) THEN CALL ZMUMPS_563(N,NZREAL,IW(IP),IW(IRNW),S2, & PERM,FLAG(1)) ELSE CALL ZMUMPS_562(N,NZREAL,IW(IP),IW(IRNW), & PERM,FLAG(1)) ENDIF IF(NZREAL .NE. I) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1 LDW = 1 ENDIF CALL ZMUMPS_559(MTRANSLOC ,N, N, NZREAL, & IW(IP), IW(IRNW), S2(1), LS2, & NUMNZ, PERM, LIW, IW(IPIW), LDW, S2(LS2+1), & ICNTL64, CNTL64, INFO64) 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(PLENR+JPERM-1) = 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(PLENR+J-1) 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_203' 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_203' 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 id%ROWSCA(J) = exp(S2(RSPOS+J)) 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+J)) IF(id%COLSCA(J) .EQ. ZERO) THEN id%COLSCA(J) = ONE ENDIF ELSE id%COLSCA(IW(PLENR+J-1))= exp(S2(CSPOS+J)) IF(id%COLSCA(IW(PLENR+J-1)) .EQ. ZERO) THEN id%COLSCA(IW(PLENR+J-1)) = 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_203' 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_203' 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)+S2(CSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO S2(CSPOS+J)= ZERO ENDIF ENDDO DO J=1,N IF(PERM(J) .GT. 0) THEN id%ROWSCA(J) = & exp((S2(RSPOS+J)+S2(CSPOS+J))/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 J = IW(IP+I-1),IW(IP+I) - 1 IF ( PERM( IW( IRNW+J-1) ) > 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_551( & N, NZREAL, IW(IP), 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_203' 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_203' WRITE (LP,'(A,I9)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -5 INFO(2) = LIWG GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_203' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 INFO(2) = LDW 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) RETURN END SUBROUTINE ZMUMPS_203 SUBROUTINE ZMUMPS_100 &( 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) 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_100 SUBROUTINE ZMUMPS_97 & ( 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) MAX_DEPTH=1 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) 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_313 & ( 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_97 RECURSIVE SUBROUTINE ZMUMPS_313 & ( 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_50, & MUMPS_52 EXTERNAL MUMPS_50, & MUMPS_52 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_50 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB) NSLAVESMAX = MUMPS_52 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB) 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 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 ) CALL ZMUMPS_313 & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG ) IF (.NOT. SPLITROOT) THEN CALL ZMUMPS_313 & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG ) ENDIF RETURN END SUBROUTINE ZMUMPS_313 SUBROUTINE ZMUMPS_351 & (N,NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, MedDens, NBQD, AvgDens) INTEGER N,NZ,LW,IFLAG,IERROR,NRORM,NIORM,IWFR INTEGER symmetry, SYM INTEGER MedDens, NBQD, AvgDens INTEGER ICNTL(40) INTEGER IRN(NZ), ICN(NZ) INTEGER LEN(N) INTEGER IPE(N+1) INTEGER FLAG(N), IW(LW) INTEGER IQ(N) INTEGER MP, MPG INTEGER I,K,J,N1,LAST,NDUP,K1,K2,L INTEGER NBERR, THRESH INTEGER NZOFFA, NDIAGA DOUBLE PRECISION RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NIORM = 3*N NDIAGA = 0 IERROR = 0 DO 10 I=1,N IPE(I) = 0 10 CONTINUE DO 50 K=1,NZ I = IRN(K) J = ICN(K) 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 IPE(J) = IPE(J) + 1 NIORM = NIORM + 1 ELSE NDIAGA = NDIAGA + 1 ENDIF ENDIF 50 CONTINUE NZOFFA = NIORM - 3*N 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 K=1,NZ I = IRN(K) J = ICN(K) 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(K,10).GT.3 .OR. mod(K,10).EQ.0 .OR. & (10.LE.K .AND. K.LE.20)) THEN WRITE (MP,'(I8,A,I8,A,I8,A)') & K,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K,10).EQ.1) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'st entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.2) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.3) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2*N IQ(1) = 1 N1 = N - 1 IF (N1.GT.0) THEN DO 110 I=1,N1 IQ(I+1) = IPE(I) + IQ(I) 110 CONTINUE 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 DO 200 K=1,NZ I = IRN(K) J = ICN(K) 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 200 CONTINUE NDUP = 0 DO 260 I=1,N K1 = IPE(I) K2 = IQ(I) -1 IF (K1.GT.K2) THEN LEN(I) = 0 IQ(I) = 0 ELSE DO 240 K=K1,K2 J = -IW(K) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1 IW(L) = 0 IW(K) = 0 ELSE IW(L) = I IW(K) = J FLAG(J) = I ENDIF 240 CONTINUE 250 IQ(I) = IQ(I) - IPE(I) IF (NDUP.EQ.0) LEN(I) = IQ(I) ENDIF 260 CONTINUE IF (NDUP.NE.0) THEN IWFR = 1 DO 280 I=1,N IF (IQ(I).EQ.0) THEN LEN(I) = 0 IPE(I) = IWFR GOTO 280 ENDIF K1 = IPE(I) K2 = K1 + IQ(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K=K1,K2 IF (IW(K).NE.0) THEN IW(IWFR) = IW(K) IWFR = IWFR + 1 ENDIF 270 CONTINUE LEN(I) = IWFR - L 280 CONTINUE ENDIF IPE(N+1) = IPE(N) + LEN(N) IWFR = IPE(N+1) IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2*NZOFFA - (IWFR-1))/ & dble(NZOFFA+NDIAGA) symmetry = nint (100.0D0*RSYM) IF (MPG .GT. 0) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ELSE symmetry = 100 ENDIF AvgDens = nint(dble(IWFR-1)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN IQ(1:N) = 0 DO I= 1, N K = max(LEN(I),1) IQ(K) = IQ(K) + 1 IF (K.GT.THRESH) NBQD = NBQD+1 ENDDO K = 0 MedDens = 0 DO WHILE (K .LT. (N/2)) MedDens = MedDens + 1 K = K+IQ(MedDens) ENDDO ELSE MedDens = AvgDens ENDIF IF (MPG .GT. 0) & write(MPG,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE ZMUMPS_351 SUBROUTINE ZMUMPS_701(N, SYM, NPROCS, IORD, & symmetry,MedDens, NBQD, AvgDens, & PROK, MP) IMPLICIT NONE INTEGER, intent(in) :: N, NPROCS, SYM INTEGER, intent(in) :: symmetry,MedDens, 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) 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 (NBQD.GE.MedDens*NPROCS) THEN IORD = 6 RETURN ENDIF #if defined(metis) || defined(parmetis) 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 (NBQD.GE.MedDens*NPROCS) THEN IORD = 6 RETURN ENDIF #if defined(metis) || defined(parmetis) 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 ZMUMPS_701 SUBROUTINE ZMUMPS_510 & (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_510 SUBROUTINE ZMUMPS_559(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & ICNTL,CNTL,INFO) IMPLICIT NONE INTEGER NICNTL, NCNTL, NINFO PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER JOB,M,N,NE,NUM,LIW,LDW INTEGER IP(N+1),IRN(NE),PERM(M),IW(LIW) INTEGER ICNTL(NICNTL),INFO(NINFO) INTEGER LA DOUBLE PRECISION A(LA) DOUBLE PRECISION DW(LDW),CNTL(NCNTL) INTEGER I,J,K,WARN1,WARN2,WARN4 DOUBLE PRECISION FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0D+00,ONE=1.0D+0) EXTERNAL ZMUMPS_457,ZMUMPS_444,ZMUMPS_451, & ZMUMPS_452,ZMUMPS_454 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 INFO(2) = NE IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = 4*N + M IF (JOB.EQ.2) K = 2*N + 2*M IF (JOB.EQ.3) K = 8*N + 2*M + NE IF (JOB.EQ.4) K = 3*N + 2*M IF (JOB.EQ.5) K = 3*N + 2*M IF (JOB.EQ.6) K = 3*N + 2*M + NE IF (LIW.LT.K) THEN INFO(1) = -4 INFO(2) = K 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 = M IF (JOB.EQ.3) K = 1 IF (JOB.EQ.4) K = 2*M IF (JOB.EQ.5) K = N + 2*M IF (JOB.EQ.6) K = N + 3*M IF (LDW.LT.K) THEN INFO(1) = -5 INFO(2) = K 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 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(J),J=1,min(10,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,min(10,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(J),J=1,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,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) = IP(J+1) - IP(J) 10 CONTINUE CALL ZMUMPS_457(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_444(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(2*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_451(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL ZMUMPS_452(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) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1 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 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IW(1) = JOB CALL ZMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) 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 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 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 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 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_451(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 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 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IW(1) = JOB IF (JOB.EQ.5) THEN CALL ZMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL ZMUMPS_454(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) 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 (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_443. INFO(1) = ',I2, & ' because ',(A),' = ',I10) 9004 FORMAT (' ****** Error in ZMUMPS_443. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I8) 9005 FORMAT (' ****** Error in ZMUMPS_443. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I8) 9006 FORMAT (' ****** Error in ZMUMPS_443. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in ZMUMPS_443. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from ZMUMPS_443. 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_443:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I10) 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_443:'/ & ' 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_559 SUBROUTINE ZMUMPS_563(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER N,NZ INTEGER IP(N+1),IRN(NZ) DOUBLE PRECISION A(NZ) INTEGER WR_POS,BEG_COL,ROW,COL,K,SV_POS INTEGER FLAG(N), POSI(N) FLAG = 0 WR_POS = 1 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1 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 RETURN END SUBROUTINE ZMUMPS_563 SUBROUTINE ZMUMPS_562(N,NZ,IP,IRN,FLAG,POSI) IMPLICIT NONE INTEGER N,NZ INTEGER IP(N+1),IRN(NZ) INTEGER WR_POS,BEG_COL,ROW,COL,K INTEGER FLAG(N), POSI(N) FLAG = 0 WR_POS = 1 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1 RETURN END SUBROUTINE ZMUMPS_562 SUBROUTINE ZMUMPS_181( 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_181 SUBROUTINE ZMUMPS_746( ID, PTRAR ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE include 'mpif.h' TYPE(ZMUMPS_STRUC), INTENT(IN), TARGET :: ID INTEGER, TARGET :: PTRAR(ID%N,2) INTEGER :: IERR INTEGER :: IOLD, K, JOLD, INEW, JNEW, INZ INTEGER, POINTER :: IIRN(:), IJCN(:), IWORK1(:), IWORK2(:) LOGICAL :: IDO, PARANAL PARANAL = .TRUE. IF (PARANAL) THEN IF(ID%KEEP(54) .EQ. 3) THEN IIRN => ID%IRN_loc IJCN => ID%JCN_loc INZ = ID%NZ_loc IWORK1 => PTRAR(1:ID%N,2) allocate(IWORK2(ID%N)) IDO = .TRUE. ELSE IIRN => ID%IRN IJCN => ID%JCN INZ = ID%NZ IWORK1 => PTRAR(1:ID%N,1) IWORK2 => PTRAR(1:ID%N,2) IDO = ID%MYID .EQ. 0 END IF ELSE IIRN => ID%IRN IJCN => ID%JCN INZ = ID%NZ 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 IWORK2(IOLD) = 0 50 CONTINUE IF(IDO) THEN DO 70 K=1,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 ELSE IWORK1(JOLD) = IWORK1(JOLD) + 1 ENDIF ELSE IF ( INEW .LT. JNEW ) THEN IWORK1( IOLD ) = IWORK1( IOLD ) + 1 ELSE IWORK1( JOLD ) = IWORK1( JOLD ) + 1 END IF ENDIF ENDIF 70 CONTINUE END IF IF(PARANAL .AND. (ID%KEEP(54) .EQ. 3) ) THEN CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1,1), ID%N, MPI_INTEGER, & MPI_SUM, ID%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), ID%N, MPI_INTEGER, & MPI_SUM, ID%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR, 2*ID%N, MPI_INTEGER, & 0, ID%COMM, IERR ) END IF RETURN END SUBROUTINE ZMUMPS_746 MODULE ZMUMPS_PARALLEL_ANALYSIS USE ZMUMPS_STRUC_DEF USE TOOLS_COMMON INCLUDE 'mpif.h' PUBLIC ZMUMPS_715 INTERFACE ZMUMPS_715 MODULE PROCEDURE ZMUMPS_715 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 :: NZ_LOC, 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 :: MEMCNT, MAXMEM, MP, MPG, LP, NRL, TOPROWS LOGICAL :: PROK, PROKG CONTAINS SUBROUTINE ZMUMPS_715(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) 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%NZ_loc = id%NZ ELSE id%NZ_loc = 0 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) MEMCNT = size(work1)+ size(work2) + & size(nfsiz) + size(fils) + size(frere) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT entry:',MEMCNT,MAXMEM #endif CALL ZMUMPS_716(id, ord) id%INFOG(7) = id%KEEP(245) CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL ZMUMPS_717(id, ord, WORK2) CALL MUMPS_276( 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_733(IPE, id%N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NV, id%N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT ipe nv:',MEMCNT,MAXMEM #endif END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 CALL ZMUMPS_720(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_276( 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_734(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT firstlast:',MEMCNT,MAXMEM #endif 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_733(CUMUL, id%N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT cumul:',MEMCNT,MAXMEM #endif NEMIN = id%KEEP(1) CALL ZMUMPS_557(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_734(CUMUL, NV, IPE, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall cumul:',MEMCNT,MAXMEM #endif CALL ZMUMPS_201(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_209(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_510(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 IF ( huge(id%KEEP8(79)) / K79REF + 1_8 .GE. & int(id%NSLAVES,8) ) THEN id%KEEP8(79)=huge(id%KEEP8(79)) ELSE id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF 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_97(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_97(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 #if defined (memprof) write(mp,'(i2,a30,3(i8,5x))')myid,'MEMCNT exit:',MEMCNT,MAXMEM, & estimem(myid, id%n, 2*id%nz/id%n) #endif RETURN END SUBROUTINE ZMUMPS_715 SUBROUTINE ZMUMPS_716(id, ord) TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: IERR #if defined(parmetis) 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) IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to PT-SCOTCH.")') RETURN #endif #if defined(parmetis) I=1 DO IF (I .GT. id%NSLAVES) 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.")') 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) I=1 DO IF (I .GT. id%NSLAVES) 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_716 SUBROUTINE ZMUMPS_717(id, ord, WORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) #ifdef parmetis INTEGER :: IERR #endif IF (ord%ORDTOOL .EQ. 1) THEN #ifdef ptscotch CALL ZMUMPS_719(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 #ifdef parmetis CALL ZMUMPS_718(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_717 #if defined(parmetis) SUBROUTINE ZMUMPS_718(id, ord, WORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR, BASE INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & EDGELOCNBR, OPTIONS(10), NROWS_LOC INTEGER, POINTER :: VERTLOCTAB(:), & EDGELOCTAB(:), RCVCNTS(:) 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) IF(MUMPS_795(WORK) .LT. ID%N*3) THEN WRITE(LP, & '("Insufficient workspace inside ZMUMPS_718")') CALL MUMPS_ABORT() END IF CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, LP, & STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, LP, & STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT perm peri:', & MEMCNT,MAXMEM #endif BASEVAL = 1 BASE = id%NPROCS-id%NSLAVES VERTLOCTAB => ord%PERMTAB CALL MUMPS_733(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, & MAXMEM #endif DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO DO I=BASE, BASE+ord%NSLAVES-2 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) END DO FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* & (BASE+ord%NSLAVES-1-BASE)+1 LAST(BASE+ord%NSLAVES) = id%N DO I=BASE+ord%NSLAVES, NPROCS FIRST(I+1) = id%N+1 LAST(I+1) = id%N END DO VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 SWORK => WORK(id%N+1:3*id%N) CALL ZMUMPS_776(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 OPTIONS(:) = 0 NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 ORDER => WORK(1:id%N) CALL MUMPS_733(SIZES, 2*ord%NSLAVES, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT sizes:',MEMCNT,MAXMEM #endif IF(ord%IDO) THEN CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB, & EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES) END IF CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM #endif NULLIFY(VERTLOCTAB) CALL MPI_BCAST(SIZES, 2*ord%NSLAVES, MPI_INTEGER, & BASE, id%COMM, IERR) ord%CBLKNBR = 2*ord%NSLAVES-1 CALL MUMPS_733(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rcvcnts:',MEMCNT,MAXMEM #endif 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, NROWS_LOC, MPI_INTEGER, ord%PERMTAB, & RCVCNTS, FIRST, MPI_INTEGER, id%COMM, IERR ) DO I=1, id%N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_733(ord%RANGTAB, 2*ord%NSLAVES, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rangtab:',MEMCNT,MAXMEM #endif CALL MUMPS_733(ord%TREETAB, ord%CBLKNBR, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_778(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_734(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sizes:',MEMCNT,MAXMEM #endif CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM #endif CALL ZMUMPS_777(ord) ord%N = id%N ord%COMM = id%COMM RETURN END SUBROUTINE ZMUMPS_718 #endif #if defined(ptscotch) SUBROUTINE ZMUMPS_719(id, ord, WORK) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & EDGELOCNBR, MYWORKID, & BASE INTEGER, POINTER :: VERTLOCTAB(:), & EDGELOCTAB(:) DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) IF(MUMPS_795(WORK) .LT. ID%N*3) THEN WRITE(LP, & '("Insufficient workspace inside ZMUMPS_719")') CALL MUMPS_ABORT() END IF IF(ord%SUBSTRAT .EQ. 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=n{sep=/(vert>120)?'// & '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=f{cmin=15,cmax=100000,frat=0.0},ose=g}}' ELSE 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 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_733(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, & MAXMEM #endif DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO DO I=BASE, BASE+ord%NSLAVES-2 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) END DO FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* & (BASE+ord%NSLAVES-1-BASE)+1 LAST(BASE+ord%NSLAVES) = id%N DO I=BASE+ord%NSLAVES, NPROCS-1 FIRST(I+1) = id%N+1 LAST(I+1) = id%N END DO VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 VERTLOCTAB => WORK(1:id%N) SWORK => WORK(id%N+1:3*id%N) CALL ZMUMPS_776(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%RANGTAB, id%N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%TREETAB, id%N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT permtab:',MEMCNT,MAXMEM #endif IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF IF(ord%IDO) THEN CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in dgraph init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), VERTLOCTAB(1), & VERTLOCTAB(1), EDGELOCNBR, EDGELOCNBR, EDGELOCTAB(1), & EDGELOCTAB(1), EDGELOCTAB(1), IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in dgraph build")') CALL MUMPS_ABORT() END IF CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in strat init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in strat build")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order compute")') CALL MUMPS_ABORT() END IF IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB, ord%PERITAB, ord%CBLKNBR, ord%RANGTAB, & ord%TREETAB, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in Corder init")') CALL MUMPS_ABORT() END IF END IF IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order gather")') CALL MUMPS_ABORT() END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order gather")') CALL MUMPS_ABORT() END IF END IF END IF IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERITAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB, id%N+1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%TREETAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_777(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM #endif ord%N = id%N ord%COMM = id%COMM CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM #endif RETURN END SUBROUTINE ZMUMPS_719 #endif FUNCTION ZMUMPS_793(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: ZMUMPS_793 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 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF ZMUMPS_793 = .FALSE. IF(NACTIVE .GE. RPROC) THEN ZMUMPS_793 = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN ZMUMPS_793 = .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 NZ_ROW = 2*(id%NZ/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_793 = .TRUE. RETURN ELSE ZMUMPS_793 = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION ZMUMPS_793 FUNCTION ZMUMPS_779(NODE, ord) IMPLICIT NONE INTEGER :: ZMUMPS_779 INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR ZMUMPS_779 = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE ZMUMPS_779 = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN ZMUMPS_779 = ZMUMPS_779+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION ZMUMPS_779 SUBROUTINE ZMUMPS_781(ord, id) USE TOOLS_COMMON 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 ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1)) ALIST(1) = ord%CBLKNBR AWEIGHTS(1) = ord%NW(ord%CBLKNBR) NACTIVE = 1 RPROC = NNODES ANODE = 0 PEAKMEM = 0 CALL MUMPS_733(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%FIRST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%LAST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')ord%myid,'MEMCNT topnodes:',MEMCNT, & MAXMEM #endif ord%TOPNODES = 0 IF((ord%CBLKNBR .EQ. 1) .OR. & ( RPROC .LT. ZMUMPS_779(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 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = ZMUMPS_779(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_793(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_783(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL ZMUMPS_784(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_783(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL ZMUMPS_784(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_781 SUBROUTINE ZMUMPS_720(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, POINTER :: PE(:), IPE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & RCVCNT(:), LSTVAR(:) INTEGER, POINTER :: NROOTS(:), MYLIST(:), & MYNVAR(:), LVARPT(:), & DISPLS(:), LPERM(:), & LIPERM(:), & IPET(:), NVT(:), BUF_PE1(:), & BUF_PE2(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP1(:), TMP2(:), BWORK(:) INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, MYNROOTS, PNT, TMP, & NCLIQUES, NTVAR, PFREES, PFREET, TGSIZE, MAXS, RHANDPE, & RHANDNV, STATUSPE(MPI_STATUS_SIZE), & STATUSNV(MPI_STATUS_SIZE), RIDX, PROC, NBBUCK, & PFS_SAVE, PFT_SAVE LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, RCVCNT, LSTVAR) nullify(NROOTS, MYLIST, MYNVAR, LVARPT, DISPLS, & 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_795(WORK) .LT. 4*id%N) THEN WRITE(LP,*)'Insufficient workspace in ZMUMPS_720' 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_781(ord, id) CALL MUMPS_734(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))') myid,'deall son:',MEMCNT,MAXMEM #endif 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_775(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK) 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_733(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT allsub:',MEMCNT,MAXMEM #endif 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 IF (ord%SUBSTRAT .EQ. 0) THEN DO I=1, HIDX PERM(I) = I END DO CALL MUMPS_420(1, THRESH, NDENSE(1), HIDX, & MUMPS_795(PE), 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) ELSE NBBUCK = 2*TMP CALL MUMPS_419 (ord%SUBSTRAT, 1, .FALSE., HIDX, NBBUCK, & MUMPS_795(PE), IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), PERM(1), NEXT(1), & W(1), HEAD(1), AGG6, SIZE_SCHUR, LISTVAR_SCHUR(1) ) DO I=1, HIDX PERM(I) = I END DO END IF CALL MUMPS_733(W, 2*NPROCS, id%INFO, & LP, STRING='W', MEMCNT=MEMCNT, ERRCODE=-7) if(MEMCNT .gt. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT w:',MEMCNT,MAXMEM #endif NROOTS => W DISPLS => W(NPROCS+1:2*NPROCS) MYNVAR => DEGREE MYLIST => NDENSE LVARPT => NEXT RCVCNT => HEAD LSTVAR => LAST NULLIFY(W, DEGREE, NDENSE, NEXT, HEAD, LAST) MYNROOTS = 0 PNT = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN PNT = PNT+LENG(I) MYNROOTS = MYNROOTS+1 END IF END DO CALL MUMPS_733(MYLIST, PNT, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT mylist:',MEMCNT,MAXMEM #endif MYNROOTS = 0 PNT = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYNROOTS = MYNROOTS+1 MYNVAR(MYNROOTS) = LENG(I) DO J=1, LENG(I) MYLIST(PNT+J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO PNT = PNT+LENG(I) END IF END DO CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_GATHER(MYNROOTS, 1, MPI_INTEGER, NROOTS(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) IF(MYID .EQ.0) THEN DISPLS(1) = 0 DO I=2, NPROCS DISPLS(I) = DISPLS(I-1)+NROOTS(I-1) END DO NCLIQUES = sum(NROOTS(1:NPROCS)) CALL MUMPS_733(LVARPT, NCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ELSE CALL MUMPS_733(LVARPT, 2, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT lvarpt:',MEMCNT,MAXMEM #endif CALL MPI_GATHERV(MYNVAR(1), MYNROOTS, MPI_INTEGER, LVARPT(2), & NROOTS(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) IF(MYID .EQ. 0) THEN DO I=1, NPROCS RCVCNT(I) = sum(LVARPT(2+DISPLS(I):2+DISPLS(I)+NROOTS(I)-1)) IF(I .EQ. 1) THEN DISPLS(I) = 0 ELSE DISPLS(I) = DISPLS(I-1)+RCVCNT(I-1) END IF END DO CALL MUMPS_733(LSTVAR, sum(RCVCNT(1:NPROCS)), id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT lstvar:',MEMCNT,MAXMEM #endif END IF CALL MPI_GATHERV(MYLIST(1), PNT, MPI_INTEGER, LSTVAR(1), & RCVCNT(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) NULLIFY(DISPLS) IF(MYID .EQ. 0) THEN LVARPT(1) = 1 DO I=2, NCLIQUES+1 LVARPT(I) = LVARPT(I-1) + LVARPT(I) END DO LPERM => WORK(3*id%N+1 : 4*id%N) NTVAR = ord%TOPNODES(2) CALL ZMUMPS_782(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL ZMUMPS_774(id, ord%TOPNODES(2), LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPET, PE, LENG, ELEN) TGSIZE = ord%TOPNODES(2)+NCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) CALL MUMPS_734(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) W => NROOTS DEGREE => MYNVAR NDENSE => MYLIST NEXT => LVARPT HEAD => RCVCNT LAST => LSTVAR NULLIFY(NROOTS, MYNVAR, MYLIST, LVARPT, RCVCNT, LSTVAR) CALL MUMPS_733(PE, max(PFREET+TGSIZE,1), id%INFO, LP, & COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LISTVAR_SCHUR, max(NCLIQUES,1), id%INFO, LP, & STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT pe:',MEMCNT,MAXMEM #endif DO I=1, NCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 IF(ord%TOPSTRAT .EQ. 0) THEN CALL MUMPS_733(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rehead:',MEMCNT,MAXMEM #endif DO I=1, TGSIZE PERM(I) = I END DO CALL MUMPS_420(2, -1, NDENSE(1), TGSIZE, & MUMPS_795(PE), 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), NCLIQUES, & AGG6) ELSE NBBUCK = 2*TGSIZE CALL MUMPS_733(HEAD, NBBUCK+2, id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(PERM, TGSIZE, id%INFO, & LP, STRING='J2:PERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rehead:',MEMCNT,MAXMEM #endif CALL MUMPS_419 (ord%TOPSTRAT, 2, .FALSE., TGSIZE, & NBBUCK, MUMPS_795(PE), IPET(1), PFREET, LENG(1), & PE(1), NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), & PERM(1), NEXT(1), W(1), HEAD(1), AGG6, NCLIQUES, & LISTVAR_SCHUR(1) ) END IF END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MUMPS_734(LISTVAR_SCHUR, PE, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall lvs:',MEMCNT,MAXMEM #endif IF(MYID .EQ. 0) THEN BUF_PE1 => WORK( 1 : id%N) BUF_PE2 => WORK( id%N+1 : 2*id%N) BUF_NV1 => WORK(2*id%N+1 : 3*id%N) BUF_NV2 => WORK(3*id%N+1 : 4*id%N) 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_733(BUF_PE1, MAXS, id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_PE2, MAXS, id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_NV1, MAXS, id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_NV2, MAXS, id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(GPE, id%N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(GNV, id%N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ROOTPERM, NCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT buf_pe1:',MEMCNT, & MAXMEM #endif 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_INTEGER, 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, NCLIQUES 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_INTEGER, 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_734(PE, IPE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_734(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_734(LSTVAR, NROOTS, MYLIST, MYNVAR, & LVARPT, MEMCNT=MEMCNT) CALL MUMPS_734(LPERM, LIPERM, IPET, NVT, & MEMCNT=MEMCNT) CALL MUMPS_734(ROOTPERM, TMP1, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, RCVCNT) RETURN END SUBROUTINE ZMUMPS_720 SUBROUTINE ZMUMPS_782(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_733(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT lperm:',MEMCNT, & MAXMEM #endif 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_782 SUBROUTINE ZMUMPS_774(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(:), LVARPT(:), & IPE(:), PE(:), LENG(:), ELEN(:) INTEGER :: NCLIQUES INTEGER :: I, J, IDX, NLOCVARS, PNT, SAVEPNT CALL MUMPS_733(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT leng:',MEMCNT, & MAXMEM #endif LENG = 0 ELEN = 0 DO I=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN LENG(LPERM(top_graph%IRN_LOC(I))) = & LENG(LPERM(top_graph%IRN_LOC(I))) + 1 END IF END DO DO I=1, NCLIQUES DO J=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+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)+LENG(I)+ELEN(I) END DO CALL MUMPS_733(PE, IPE(NLOCVARS+NCLIQUES+1)+NLOCVARS+NCLIQUES, & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT repe:',MEMCNT, & MAXMEM #endif LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO J=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(J)) PE(IPE(IDX)+ELEN(IDX)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+LENG(NLOCVARS+I)) = IDX ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO I=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN PE(IPE(LPERM(top_graph%IRN_LOC(I)))+ & ELEN(LPERM(top_graph%IRN_LOC(I))) + & LENG(LPERM(top_graph%IRN_LOC(I)))) = & LPERM(top_graph%JCN_LOC(I)) LENG(LPERM(top_graph%IRN_LOC(I))) = & LENG(LPERM(top_graph%IRN_LOC(I))) + 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 J=IPE(I), IPE(I+1)-1 IF(LPERM(PE(J)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE ZMUMPS_774 SUBROUTINE ZMUMPS_778(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:2) = (/1, 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_778 SUBROUTINE ZMUMPS_776(id, FIRST, LAST, IPE, & PE, WORK) IMPLICIT NONE INCLUDE 'mpif.h' TYPE(ZMUMPS_STRUC) :: id INTEGER, POINTER :: FIRST(:), LAST(:), IPE(:), PE(:), & WORK(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, LOCNNZ, & NEW_LOCNNZ, J, LOC_ROW INTEGER :: TOP_CNT, TIDX, & NROWS_LOC, DUPS, TOTDUPS, OFFDIAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), & SNDCNT(:), RCVCNT(:), SDISPL(:) INTEGER, POINTER :: RDISPL(:), & MSGCNT(:), SIPES(:,:), LENG(:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, & SAVEPNT INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL) nullify(RDISPL, MSGCNT, SIPES, LENG) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_795(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_733(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT sndcnt:',MEMCNT,MAXMEM #endif ALLOCATE(APNT(NPROCS)) SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 1000 LOCNNZ = id%NZ_loc 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 I=1, id%NZ_loc IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(I)) LOC_ROW = id%IRN_loc(I)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(I)) LOC_ROW = id%JCN_loc(I)-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%KEEP(114), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) id%KEEP(114) = id%KEEP(114)+3*id%N id%KEEP(113) = id%KEEP(114)-2*id%N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, id%COMM, IERR) SNDCNT(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) CALL MUMPS_733(IPE, NROWS_LOC+1, id%INFO, & LP, STRING='IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT ripe:',MEMCNT,MAXMEM #endif IPE(1) = 1 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + LENG(I) END DO CALL MUMPS_733(PE, max(IPE(NROWS_LOC+1)-1,1), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe:',MEMCNT,MAXMEM #endif LENG(:) = 0 CALL ZMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) NEW_LOCNNZ = sum(RCVCNT) DO I=1, NPROCS MSGCNT(I) = RCVCNT(I)/BUFSIZE END DO RCVPNT = 1 SNDCNT = 0 TIDX = 0 DO I=1, id%NZ_loc IF(mod(I,BUFSIZE/10) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, MPI_COMM_WORLD, STATUS, IERR) CALL ZMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%IRN_loc(I)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%JCN_loc(I) SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF PROC = MAPTAB(id%JCN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%JCN_loc(I)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%IRN_loc(I) SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF END DO CALL ZMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO J=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(J)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER, MPI_SUM, & 0, id%COMM, IERR ) SYMMETRY = dble(TOTDUPS)/(dble(id%NZ)-dble(id%N)) IF(MYID .EQ. 0) THEN IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'("Structual symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_734(SNDCNT, RCVCNT, MSGCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM #endif RETURN END SUBROUTINE ZMUMPS_776 SUBROUTINE ZMUMPS_775(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK) IMPLICIT NONE INCLUDE 'mpif.h' TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: IPE(:), PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, LOCNNZ, & NEW_LOCNNZ, J, LOC_ROW INTEGER :: TOP_CNT,IIDX,JJDX INTEGER :: HALO_SIZE, TIDX, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), & SNDCNT(:), RCVCNT(:), & SDISPL(:), HALO_MAP(:) INTEGER, POINTER :: RDISPL(:), & MSGCNT(:), SIPES(:,:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, & SAVEPNT INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_795(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_733(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rrsndcnt:',MEMCNT,MAXMEM #endif ALLOCATE(APNT(NPROCS)) SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 LOCNNZ = id%NZ_loc 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 I=1, id%NZ_loc IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(I)) 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(I)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(I)) 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_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, id%COMM, IERR) I = ceiling(dble(MAXS)*1.20D0) CALL MUMPS_733(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrleng2:',MEMCNT, & MAXMEM #endif SNDCNT(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(dble(NROWS_LOC+1)*1.20D0) CALL MUMPS_733(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rripe:',MEMCNT,MAXMEM #endif IPE(1) = 1 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + LENG(I) END DO CALL MUMPS_733(TSENDI, max(TOP_CNT,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(TSENDJ, max(TOP_CNT,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT tsendi:',MEMCNT,MAXMEM #endif LENG(:) = 0 CALL ZMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) NEW_LOCNNZ = sum(RCVCNT) DO I=1, NPROCS MSGCNT(I) = RCVCNT(I)/BUFSIZE END DO CALL MUMPS_733(PE, max(NEW_LOCNNZ+2*NROWS_LOC,1), id%INFO, & LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe2:',MEMCNT,MAXMEM #endif RCVPNT = 1 SNDCNT = 0 TIDX = 0 DO I=1, id%NZ_loc IF(mod(I,BUFSIZE/10) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, MPI_COMM_WORLD, STATUS, IERR) CALL ZMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(I) TSENDJ(TIDX) = id%JCN_loc(I) ELSE IIDX = ord%PERMTAB(id%IRN_loc(I)) JJDX = ord%PERMTAB(id%JCN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) =IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%JCN_loc(I) END IF SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(I)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(I) TSENDJ(TIDX) = id%IRN_loc(I) ELSE IIDX = ord%PERMTAB(id%JCN_loc(I)) JJDX = ord%PERMTAB(id%IRN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%IRN_loc(I) END IF SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF END IF END DO CALL ZMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO J=IPE(I),IPE(I+1)-1 IF(PE(J) .LT. 0) THEN IF(HALO_MAP(-PE(J)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(J)) = NROWS_LOC+HALO_SIZE END IF PE(J) = HALO_MAP(-PE(J)) END IF IF(MAPTAB(PE(J)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_733(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT i_halo:',MEMCNT,MAXMEM #endif 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_733(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_733(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT lengipe:',MEMCNT, & MAXMEM #endif 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_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) RDISPL => MSGCNT NULLIFY(MSGCNT) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) RDISPL(1) = 0 DO I=2, NPROCS RDISPL(I) = RDISPL(I-1)+RCVCNT(I-1) END DO top_graph%NZ_LOC = NEW_LOCNNZ top_graph%COMM = id%COMM CALL MUMPS_733(top_graph%IRN_LOC, NEW_LOCNNZ, id%INFO, & LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(top_graph%JCN_LOC, NEW_LOCNNZ, id%INFO, & LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT top_graph:',MEMCNT, & MAXMEM #endif ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1)) END IF CALL MPI_GATHERV(TSENDI(1), TOP_CNT, MPI_INTEGER, & top_graph%IRN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, & 0, id%COMM, IERR) CALL MPI_GATHERV(TSENDJ(1), TOP_CNT, MPI_INTEGER, & top_graph%JCN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, & 0, id%COMM, IERR) CALL MUMPS_734(SNDCNT, RCVCNT, RDISPL, & TSENDI, TSENDJ, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM #endif DEALLOCATE(APNT) RETURN END SUBROUTINE ZMUMPS_775 SUBROUTINE ZMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER :: NPROCS, PROC, COMM TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:), IPE(:) INTEGER :: MSGCNT(:), SNDCNT(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE, TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE), & 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_773(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_773(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_773(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_785 SUBROUTINE ZMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) #ifdef MPELOG USE MPEMOD INCLUDE 'mpif.h' #endif IMPLICIT NONE INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), IPE(:), PE(:), LENG(:) INTEGER :: I, ROW, COL #ifdef MPELOG INTEGER ::IERR IERR = MPE_LOG_EVENT( MPE_ASM_BUF1, 0, '' ) #endif 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 #ifdef MPELOG IERR = MPE_LOG_EVENT( MPE_ASM_BUF2, 0, '' ) #endif RETURN END SUBROUTINE ZMUMPS_773 SUBROUTINE ZMUMPS_777(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_777 SUBROUTINE ZMUMPS_784(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_784 SUBROUTINE ZMUMPS_783(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_783 FUNCTION MUMPS_795(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_795 IF(associated(A)) THEN MUMPS_795 = size(A) ELSE MUMPS_795 = 0 END IF RETURN END FUNCTION MUMPS_795 SUBROUTINE MUMPS_734(A1, A2, A3, A4, A5, A6, A7, MEMCNT) INTEGER, POINTER :: A1(:) INTEGER, POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:), & A6(:), A7(:) INTEGER, OPTIONAL :: MEMCNT INTEGER :: IMEMCNT IMEMCNT = 0 IF(associated(A1)) THEN IMEMCNT = IMEMCNT+size(A1) DEALLOCATE(A1) END IF IF(present(A2)) THEN IF(associated(A2)) THEN IMEMCNT = IMEMCNT+size(A2) DEALLOCATE(A2) END IF END IF IF(present(A3)) THEN IF(associated(A3)) THEN IMEMCNT = IMEMCNT+size(A3) DEALLOCATE(A3) END IF END IF IF(present(A4)) THEN IF(associated(A4)) THEN IMEMCNT = IMEMCNT+size(A4) DEALLOCATE(A4) END IF END IF IF(present(A5)) THEN IF(associated(A5)) THEN IMEMCNT = IMEMCNT+size(A5) DEALLOCATE(A5) END IF END IF IF(present(A6)) THEN IF(associated(A6)) THEN IMEMCNT = IMEMCNT+size(A6) DEALLOCATE(A6) END IF END IF IF(present(A7)) THEN IF(associated(A7)) THEN IMEMCNT = IMEMCNT+size(A7) DEALLOCATE(A7) END IF END IF IF(present(MEMCNT)) MEMCNT = MEMCNT-IMEMCNT RETURN END SUBROUTINE MUMPS_734 #if defined(memprof) FUNCTION ESTIMEM(MYID, N, NZR) INTEGER :: ESTIMEM, MYID, NZR, N IF(MYID.EQ.0) THEN ESTIMEM = 12*N ELSE ESTIMEM = 7*N END IF IF(MYID.NE.0) TOPROWS=0 IF(MYID .EQ. 0) ESTIMEM = ESTIMEM+2*TOPROWS*NZR ESTIMEM = ESTIMEM+NRL ESTIMEM = ESTIMEM+max(NRL,TOPROWS)*(NZR+2) ESTIMEM = ESTIMEM+6*max(NRL,TOPROWS) IF(MYID.EQ.0) ESTIMEM=ESTIMEM+3*TOPROWS RETURN END FUNCTION ESTIMEM #endif END MODULE SUBROUTINE ZMUMPS_448(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_448 SUBROUTINE ZMUMPS_444 & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER M,N,NE,NUM INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),PR(N),Q(M),L(M) DOUBLE PRECISION A(NE) DOUBLE PRECISION D(M), RINF INTEGER I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & K,KK,KK1,KK2,I0,UP,LOW 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_445, ZMUMPS_446, ZMUMPS_447, ZMUMPS_455 RLX = D(1) NUM = 0 BV = RINF DO 10 K = 1,N JPERM(K) = 0 PR(K) = IP(K) 10 CONTINUE DO 12 K = 1,M IPERM(K) = 0 D(K) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1 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 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 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 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1 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 DO 115 K = IP(J),IP(J+1)-1 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_445(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = J 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_446(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 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_447(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_445(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = J 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 = PR(J) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 KK = UP,M I = Q(KK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 KK = LOW,UP-1 I = Q(KK) D(I) = MINONE 192 CONTINUE DO 193 KK = 1,QLEN I = Q(KK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL ZMUMPS_455(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE ZMUMPS_444 SUBROUTINE ZMUMPS_445(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_445 SUBROUTINE ZMUMPS_446(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_446 SUBROUTINE ZMUMPS_447(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_447 SUBROUTINE ZMUMPS_450(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER WLEN,NVAL INTEGER IP(*),LENL(*),LENH(*),W(*) DOUBLE PRECISION A(*),VAL INTEGER XX,J,K,II,S,POS PARAMETER (XX=10) DOUBLE PRECISION SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+LENL(J),IP(J)+LENH(J)-1 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_450 SUBROUTINE ZMUMPS_451(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER N,NE INTEGER IP(N+1),IRN(NE) DOUBLE PRECISION A(NE) INTEGER THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER J,IPJ,K,LEN,R,S,HI,FIRST,MID,LAST,TD DOUBLE PRECISION HA,KEY INTEGER TODO(TDLEN) DO 100 J = 1,N LEN = 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 + LEN TD = 2 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 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 425 CONTINUE IF (TD.EQ.0) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.THRESH) GO TO 500 TD = TD - 2 GO TO 425 400 DO 200 R = IPJ+1,IPJ+LEN-1 IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1) IRN(R) = IRN(R-1) DO 300 S = R-1,IPJ+1,-1 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_451 SUBROUTINE ZMUMPS_452(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER M,N,NE,NUMX INTEGER IP(N+1),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,II,I,J,K,L,CNT,MOD,IDUM1,IDUM2,IDUM3 DOUBLE PRECISION BVAL,BMIN,BMAX EXTERNAL ZMUMPS_450,ZMUMPS_453,ZMUMPS_455 DO 20 J = 1,N FC(J) = J LEN(J) = 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_453(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 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 = IP(J+1) - IP(J) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = K - IP(J) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 IDUM1 = 1,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 IDUM2 = 1,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL ZMUMPS_450(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM3 = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+LEN(J)-1,IP(J)+LENL(J),-1 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) = 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_450(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM3 = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+LEN(J),IP(J)+LENH(J)-1 IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = 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_453(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_455(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE ZMUMPS_452 SUBROUTINE ZMUMPS_453 & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER ID,MOD,M,N,LIRN,NUM,NUMX INTEGER ARP(N),CV(M),IRN(LIRN),IP(N), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK,LAST,NFC, & NUM0,NUM1,NUM2,ID0,ID1 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) + ARP(J) IN2 = IP(J) + LENC(J) - 1 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 = OUT(J) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + LENC(J) - 1 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) = 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) = 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) + LENC(J) - OUT(J) - 2 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_453 SUBROUTINE ZMUMPS_454(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER M,N,NE,NUM INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),OUT(N),PR(N),Q(M),L(M) DOUBLE PRECISION A(NE),U(M),D(M),RINF,RINF3 INTEGER I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,ISP,JSP, & K,K0,K1,K2,KK,KK1,KK2,UP,LOW DOUBLE PRECISION CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL LORD DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) EXTERNAL ZMUMPS_445, ZMUMPS_446, ZMUMPS_447, ZMUMPS_455 RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 K = 1,N JPERM(K) = 0 PR(K) = IP(K) D(K) = RINF 10 CONTINUE DO 15 K = 1,M U(K) = RINF3 IPERM(K) = 0 L(K) = 0 15 CONTINUE DO 30 J = 1,N IF (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) 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 K = 1,M D(K) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1 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 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 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF L(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 DO 115 K = IP(J),IP(J+1)-1 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 Q(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 KK = 1,Q0 K = Q(KK) 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 Q(LOW) = I L(I) = LOW ELSE QLEN = QLEN + 1 L(I) = QLEN CALL ZMUMPS_445(I,M,Q,D,L,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = J 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL ZMUMPS_446(QLEN,M,Q,D,L,2) LOW = LOW - 1 Q(LOW) = I L(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = Q(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 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 (L(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 (L(I).NE.0) THEN CALL ZMUMPS_447(L(I),QLEN,M,Q,D,L,2) ENDIF LOW = LOW - 1 Q(LOW) = I L(I) = LOW ELSE IF (L(I).EQ.0) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL ZMUMPS_445(I,M,Q,D,L,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = J 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 = 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 KK = UP,M I = Q(KK) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 KK = UP,M I = Q(KK) D(I) = RINF L(I) = 0 191 CONTINUE DO 192 KK = LOW,UP-1 I = Q(KK) D(I) = RINF L(I) = 0 192 CONTINUE DO 193 KK = 1,QLEN I = Q(KK) D(I) = RINF L(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_455(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE ZMUMPS_454 SUBROUTINE ZMUMPS_457 & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER LIRN,M,N,NUM INTEGER ARP(N),CV(M),IRN(LIRN),IP(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK EXTERNAL ZMUMPS_455 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 = ARP(J) IF (IN1.LT.0) GO TO 30 IN2 = IP(J) + LENC(J) - 1 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 = OUT(J) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + LENC(J) - 1 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) = IN2 - II - 1 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) = IN2 - II - 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 1000 II = IP(J) + LENC(J) - OUT(J) - 2 I = IRN(II) IPERM(I) = J 90 CONTINUE 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL ZMUMPS_455(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE ZMUMPS_457 SUBROUTINE ZMUMPS_455(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_455 mumps-4.10.0.dfsg/src/mumps_sol_es.F0000644000175300017530000003553211562233015017512 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE MUMPS_SOL_ES PRIVATE PUBLIC:: PRUNED_SIZE_LOADED PUBLIC:: MUMPS_797 PUBLIC:: MUMPS_802 PUBLIC:: MUMPS_798 PUBLIC:: MUMPS_803 PUBLIC:: MUMPS_804 INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK INTEGER(8) :: PRUNED_SIZE_LOADED CONTAINS SUBROUTINE MUMPS_804(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_804 SUBROUTINE MUMPS_798( & 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 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 IF (IN.LT.0) THEN TMP = -IN ISTEP = STEP(TMP) ELSE nb_prun_leaves = nb_prun_leaves + 1 IF(fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF IF(TMP.NE.TMPsave) THEN TMP = abs(FRERE(ISTEP)) IF(TMP.NE.0) THEN ISTEP = STEP(TMP) END IF END IF 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_798 SUBROUTINE MUMPS_797( & 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_797 SUBROUTINE MUMPS_803(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 defined(Mila_Print) write(*,*) ' in Pruned List nodes:',nb_prun_nodes write(*,*) Pruned_List(1:nb_prun_nodes) #endif 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 #if defined(Mila_Print) write(*,*) 'Pruned_Size Total_Size:', & Pruned_Size, KEEP8_31 write(*,*) MYID,'Gain (%) = ', dble(100) & - (dble(Pruned_Size)*dble(100)) /dble(KEEP8_31) IF (Pruned_Size .EQ. 0) THEN WRITE(*,*) "NOT NORMAL BEHAVIOUR !!" DO I = 1, nb_nodes_RHS WRITE(*,*) "starting_node node_size", & nodes_RHS(I), & SIZE_OF_BLOCK(STEP(nodes_RHS(I)),OOC_FCT_TYPE_LOC) ENDDO ENDIF write(*,*) '=============================' #endif ENDIF RETURN END SUBROUTINE MUMPS_803 SUBROUTINE MUMPS_802 & (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 defined(Mila_Print) write(*,*) MYID,'PR leaves NODES',nb_prun_leaves, & Pruned_Leaves(1:nb_prun_leaves) write(*,*) MYID,'PR NODES',Pos_List, & Pruned_List(1:Pos_List) write(*,*) 'PR root NODES', & Pruned_Roots(nb_prun_roots) # endif IF (KEEP8_31 .NE. 0_8) THEN # if defined(Mila_Print) write(*,*) MYID,'PRUNED and TOTAL Size:', & Pruned_Size, KEEP8_31 write(*,*) MYID,'Gain (%) = ', dble(100) & - ((dble(Pruned_Size)*dble(100))/dble(KEEP8_31)) IF (MYID.EQ.0) & write(*,*) '=============================' # endif PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF ENDIF RETURN END SUBROUTINE MUMPS_802 END MODULE MUMPS_SOL_ES SUBROUTINE MUMPS_780 & (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 WRITE(*,*) "Processing the RHS in random order" 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 WRITE(*,*) "Processing the RHS in inverse order" DO I=1, SIZEPERM PERM_RHS(SIZEPERM -I +1) = I ENDDO ELSEIF (STRAT .EQ. -1) THEN WRITE(*,*) "Processing the RHS in natural order" DO I=1, SIZEPERM PERM_RHS(I) = I ENDDO ELSEIF (STRAT .EQ. 1) THEN WRITE(*,*) "Processing the RHS in post-order" DO I=1, SIZEPERM PERM_RHS(SYM_PERM(I)) = I ENDDO ELSEIF (STRAT .EQ. 2) THEN WRITE(*,*) "Processing the RHS in pre-order" DO I=1, SIZEPERM PERM_RHS(SIZEPERM-SYM_PERM(I)+1) = I ENDDO ENDIF END SUBROUTINE MUMPS_780 SUBROUTINE MUMPS_772 & (PERM_RHS, SIZEPERM, N, KEEP_28, & PROCNODE, STEP_S, Nprocs, Step2node, & IERR) IMPLICIT NONE INTEGER, INTENT(IN) :: SIZEPERM INTEGER, intent(in) :: N, KEEP_28, Nprocs INTEGER, intent(in) :: PROCNODE(KEEP_28), STEP_S(N) INTEGER, intent(in) :: Step2node(KEEP_28) INTEGER, INTENT(OUT):: IERR INTEGER, INTENT(INOUT):: PERM_RHS(SIZEPERM) INTEGER I, TMP_RHS, TMP2, proc_num INTEGER , ALLOCATABLE :: TEMP_LOC_ARRAY(:) INTEGER PTR(0:Nprocs-1) INTEGER MUMPS_275, MUMPS_330 EXTERNAL MUMPS_275, MUMPS_330 IERR = 0 ALLOCATE(TEMP_LOC_ARRAY(SIZEPERM), stat=IERR) IF (IERR.GT.0) THEN WRITE(6,*) " Not enough memory to allocate working ", & " arrays in MUMPS_772 " CALL MUMPS_ABORT() ENDIF proc_num = 0 PTR(:) = 1 DO I = 1, SIZEPERM 555 CONTINUE IF ( PTR(proc_num).LE.SIZEPERM ) THEN TMP_RHS = PERM_RHS(PTR(proc_num)) TMP2 = Step2node(abs (STEP_S(TMP_RHS) )) IF (proc_num .EQ. MUMPS_275 & (PROCNODE(STEP_S(TMP2)),Nprocs)) THEN TEMP_LOC_ARRAY(I) = TMP_RHS PTR(proc_num) = PTR(proc_num)+1 IF ( (MUMPS_330(PROCNODE(STEP_S(TMP2)), & Nprocs).EQ.1) & ) THEN proc_num = mod(proc_num+1,Nprocs) proc_num = mod(proc_num+1,Nprocs) ENDIF ELSE PTR(proc_num) = PTR(proc_num)+1 GOTO 555 ENDIF ELSE proc_num = mod(proc_num+1,Nprocs) GOTO 555 ENDIF ENDDO WRITE(*,*) "Used interleaving of the RHS" DO I = 1, SIZEPERM PERM_RHS(I) = TEMP_LOC_ARRAY(I) ENDDO IF (allocated(TEMP_LOC_ARRAY)) DEALLOCATE (TEMP_LOC_ARRAY) RETURN END SUBROUTINE MUMPS_772 mumps-4.10.0.dfsg/src/dmumps_part4.F0000644000175300017530000071626211562233066017440 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE DMUMPS_246(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 & ) IMPLICIT NONE 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 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_748 EXTERNAL DMUMPS_748 INTEGER MUMPS_275, MUMPS_330 LOGICAL MUMPS_170 INTEGER MUMPS_52 EXTERNAL MUMPS_503, MUMPS_52 EXTERNAL MUMPS_275, MUMPS_330, & MUMPS_170 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)) 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 = dble(0.0D0) ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = dble(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_275(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_246 ' 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_275(PROCNODE(STEP(INODE)),SLAVEF) & .EQ. MYID LEVEL = MUMPS_330(PROCNODE(STEP(INODE)),SLAVEF) INSSARBR = MUMPS_170(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_503(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_170( & 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_748( & 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_748( & 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 = NRLADU + int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU = NRLADU + int(NELIM,8)*int(NCB/NSLAVES_LOC,8) ENDIF NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) 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_246. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_275(PROCNODE(STEP(IFSON)),SLAVEF) & .EQ.MYID LEVELSON = MUMPS_330(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_246. 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_511(NFR, & NELIM, NELIM,0, & 1,OPS_NODE) ELSE CALL MUMPS_511(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_511(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 ) & ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN OPSA_LOC = OPSA_LOC + OPS_NODE / dble( SLAVEF ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(SLAVEF,8) IF (MASTER) & ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) 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_170(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_511(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_330(PROCNODE(STEP(IFATH)),SLAVEF) MASTERF= MUMPS_275(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_503( 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_246' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in DMUMPS_246 ' 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_246 RECURSIVE SUBROUTINE & DMUMPS_271( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 40 ) INTEGER(8) KEEP8(150) 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(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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(max(1,KEEP(14))) DOUBLE PRECISION DBLARR(max(1,KEEP(13))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.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, & STATUS( MPI_STATUS_SIZE ), ISON, PDEST_MASTER_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL INVERT INCLUDE 'mumps_headers.h' INTEGER MUMPS_275, MUMPS_330 EXTERNAL MUMPS_275, MUMPS_330 FPERE = KEEP(38) TYPE_SON = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( MUMPS_275( 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_271 ', 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_80( 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, .FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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 INVERT = .FALSE. ELSE INVERT = .TRUE. END IF CALL DMUMPS_80( 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_93(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_275(PROCNODE_STEPS(STEP(ISON)), SLAVEF) DO WHILE ( PTRIST(STEP(ISON)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & PDEST_MASTER_ISON, MAITRE_DESC_BANDE, & 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) RETURN ENDDO DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_271 ' 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 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_271", & IW(IOLDPS+XXS), "INODE=",INODE CALL MUMPS_ABORT() ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN INVERT = .FALSE. ELSE INVERT = .TRUE. END IF CALL DMUMPS_80( 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL DMUMPS_314( 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, TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL DMUMPS_44( MYID, SLAVEF, COMM ) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_271 SUBROUTINE DMUMPS_221(NFRONT,NASS,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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW INTEGER(8) :: LA DOUBLE PRECISION A(LA) DOUBLE PRECISION UU, SEUIL INTEGER IW(LIW) INTEGER(8) :: POSELT INTEGER IOLDPS INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INCLUDE 'mumps_headers.h' DOUBLE PRECISION SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, J3, JJ INTEGER(8) :: NFRONT8 DOUBLE PRECISION AMROW DOUBLE PRECISION RMAX DOUBLE PRECISION PIVNUL DOUBLE PRECISION FIXA, CSEUIL INTEGER NPIV,NASSW,IPIV INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW INTEGER DMUMPS_IXAMAX INTRINSIC max DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NFRONT8 = int(NFRONT,8) IF (KEEP(201).EQ.1) THEN CALL DMUMPS_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL DMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_680( 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 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF (UU.GT.RZERO) GO TO 340 IF (abs(A(APOS)).EQ.RZERO) GO TO 630 GO TO 380 340 AMROW = RZERO J1 = APOS J2 = APOS + int(- NPIV + NASS - 1,8) J = NASS -NPIV JMAX = DMUMPS_IXAMAX(J,A(J1),1) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW J1 = J2 + 1_8 J2 = APOS +int(- NPIV + NFRONT - 1 - KEEP(253),8) IF (J2.LT.J1) GO TO 370 DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF ( RMAX .LE. PIVNUL ) THEN KEEP(109) = KEEP(109)+1 ISW = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE+ & IW(IOLDPS+5+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)).GT. max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE. max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_762( & 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 + 5 + NPIVP1 + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + 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) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + 5 + NFRONT + NPIV + 1 +XSIZE ISWPS2 = IOLDPS + 5 + NFRONT + NPIV + JMAX +XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 WRITE(*,*) 'Detected a null pivot, INODE/NPIV=',INODE,NPIV GOTO 430 420 CONTINUE IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_680( 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_221 SUBROUTINE DMUMPS_220(NFRONT,NASS,N,INODE,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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,INOPV INTEGER(8) :: LA INTEGER KEEP(500) DOUBLE PRECISION DKEEP(30) DOUBLE PRECISION UU, SEUIL DOUBLE PRECISION A(LA) INTEGER IW(LIW) DOUBLE PRECISION AMROW DOUBLE PRECISION RMAX DOUBLE PRECISION SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NOFFW,NPIV,IPIV 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 DMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL DMUMPS_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL DMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF DO 460 IPIV=NPIVP1,NASS APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = DMUMPS_IXAMAX(J3,A(J1),NFRONT) 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 (J3.EQ.0) GOTO 370 DO 360 J=1,J3 RMAX = max(abs(A(J1)),RMAX) J1 = J1 + NFRONT8 360 CONTINUE 370 IF (RMAX.EQ.RZERO) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)).GE.max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LT.max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_762( & 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 390 J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 390 CONTINUE 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 410 KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 410 CONTINUE 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_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_680( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE DMUMPS_220 SUBROUTINE DMUMPS_225(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_225 SUBROUTINE DMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA,IOLDPS, & POSELT,XSIZE) IMPLICIT NONE INTEGER NFRONT,N,INODE,LIW,XSIZE INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) DOUBLE PRECISION ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS INTEGER(8) :: NFRONT8, LPOS, IRWPOS INTEGER IOLDPS,NPIV,NEL INTEGER JROW INCLUDE 'mumps_headers.h' DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 NFRONT8= int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NEL = NFRONT - NPIV - 1 APOS = POSELT + int(NPIV,8) * NFRONT8 + int(NPIV,8) IF (NEL.EQ.0) GO TO 650 VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 340 JROW = 1,NEL A(LPOS) = VALPIV*A(LPOS) LPOS = LPOS + NFRONT8 340 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS+1_8 DO 440 JROW = 1,NEL IRWPOS = LPOS + 1_8 ALPHA = -A(LPOS) CALL daxpy(NEL,ALPHA,A(UUPOS),1,A(IRWPOS),1) LPOS = LPOS + NFRONT8 440 CONTINUE 650 RETURN END SUBROUTINE DMUMPS_229 SUBROUTINE DMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,N,LIW,INODE,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,KROW, XSIZE INTEGER NEL,ICOL,NEL2 INTEGER NPIVP1 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 DO 440 ICOL = 1,NEL IRWPOS = LPOS + 1_8 ALPHA = -A(LPOS) CALL daxpy(NEL2,ALPHA,A(UUPOS),1,A(IRWPOS),1) LPOS = LPOS + NFRONT8 440 CONTINUE RETURN END SUBROUTINE DMUMPS_228 SUBROUTINE DMUMPS_231(A,LA,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER(8) :: LA,POSELT DOUBLE PRECISION A(LA) INTEGER NFRONT, NPIV, NASS INTEGER(8) :: LPOS, LPOS1, LPOS2 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) 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_231 SUBROUTINE DMUMPS_642(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_688 & ( 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_642 SUBROUTINE DMUMPS_232(A,LA,NFRONT,NPIV,NASS,POSELT,LKJIB) INTEGER NFRONT, NPIV, NASS, LKJIB INTEGER (8) :: POSELT, LA DOUBLE PRECISION A(LA) INTEGER(8) :: POSELT_LOCAL, LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPBEG DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) POSELT_LOCAL = POSELT NEL1 = NASS - NPIV NPBEG = NPIV - LKJIB + 1 NEL11 = NFRONT - NPIV LPOS2 = POSELT_LOCAL + int(NPIV,8)*int(NFRONT,8) & + int(NPBEG - 1,8) POSELT_LOCAL = POSELT_LOCAL + int(NPBEG-1,8)*int(NFRONT,8) & + int(NPBEG-1,8) CALL dtrsm('L','L','N','N',LKJIB,NEL1,ONE,A(POSELT_LOCAL), & NFRONT,A(LPOS2),NFRONT) LPOS = LPOS2 + int(LKJIB,8) LPOS1 = POSELT_LOCAL + int(LKJIB,8) CALL dgemm('N','N',NEL11,NEL1,LKJIB,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE DMUMPS_232 SUBROUTINE DMUMPS_233(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT,XSIZE ) IMPLICIT NONE INTEGER NFRONT, NASS,N,LIW INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG,LKJIB, INODE, IBEG_BLOCK INTEGER(8) :: POSELT, LPOS, LPOS1, LPOS2, POSLOCAL INTEGER(8) :: IPOS, KPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1, NEL11 INTEGER LBP, HF INTEGER LBPT,I1,K1,II,ISWOP,LBP1 INTEGER LKJIT, XSIZE INCLUDE 'mumps_headers.h' DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) JROW2 = iabs(IW(IOLDPS+3+XSIZE)) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+XSIZE) +XSIZE NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+XSIZE)= min0(NPIV+LKJIB,NASS) ELSE IW(IOLDPS+3+XSIZE) = NASS ENDIF IBEG_BLOCK = NPIV + 1 NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 NEL11 = NFRONT - NPIV IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN LPOS2 = POSELT + int(JROW2,8)*NFRONT8 + & int(NPBEG - 1,8) POSLOCAL = POSELT + int(NPBEG-1,8)*NFRONT8 + int(NPBEG - 1,8) CALL dtrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSLOCAL),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSLOCAL + int(LKJIW,8) CALL dgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF RETURN END SUBROUTINE DMUMPS_233 SUBROUTINE DMUMPS_236(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_236 SUBROUTINE DMUMPS_217(N, NZ, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NZ, NSCA INTEGER IRN(NZ), ICN(NZ) INTEGER ICNTL(40), INFO(40) DOUBLE PRECISION ASPK(NZ) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER LWK, LWK_REAL DOUBLE PRECISION WK(LWK) DOUBLE PRECISION WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER IWNOR INTEGER I, K LOGICAL PROK DOUBLE PRECISION ONE PARAMETER( ONE = 1.0D0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROK = (MPG.GT.0) IF (PROK) WRITE(MPG,101) 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROK) & WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.2) THEN IF (PROK) & WRITE (MPG,*) ' SCALING BASED ON (MC29)' 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)' ELSEIF (NSCA.EQ.5) THEN IF (PROK) & WRITE (MPG,*) ' MC29 FOLLOWED BY ROW &COL SCALING' ELSEIF (NSCA.EQ.6) THEN IF (PROK) & WRITE (MPG,*) ' MC29 FOLLOWED BY COLUMN SCALING' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF ((NSCA.EQ.5).OR. & (NSCA.EQ.6)) THEN IF (NZ.GT.LWK) GOTO 400 DO 15 K=1,NZ WK(K) = ASPK(K) 15 CONTINUE ENDIF IF (5*N.GT.LWK_REAL) GOTO 410 IWNOR = 1 IF (NSCA.EQ.1) THEN CALL DMUMPS_238(N,NZ,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.2) THEN CALL DMUMPS_239(N,NZ,ASPK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) ELSEIF (NSCA.EQ.3) THEN CALL DMUMPS_241(N,NZ,ASPK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN CALL DMUMPS_287(N,NZ,IRN,ICN,ASPK, & WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.5) THEN CALL DMUMPS_239(N,NZ,WK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) CALL DMUMPS_241(N,NZ,WK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.6) THEN CALL DMUMPS_239(N,NZ,WK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) CALL DMUMPS_240(NSCA,N,NZ,IRN,ICN,WK, & WK_REAL(IWNOR+N),ROWSCA,MPG) CALL DMUMPS_241(N,NZ,WK,IRN,ICN, & WK_REAL(IWNOR), COLSCA, MPG) ENDIF GOTO 500 400 INFO(1) = -5 INFO(2) = NZ-LWK IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' 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_217 SUBROUTINE DMUMPS_287(N,NZ,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER N, NZ DOUBLE PRECISION VAL(NZ) DOUBLE PRECISION RNOR(N),CNOR(N) DOUBLE PRECISION COLSCA(N),ROWSCA(N) DOUBLE PRECISION CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ), ICN(NZ) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J,K 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 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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_287 SUBROUTINE DMUMPS_239(N,NZ,VAL,ROWIND,COLIND, & RNOR,CNOR,WNOR,MPRINT,MP, & NSCA) INTEGER N, NZ DOUBLE PRECISION VAL(NZ) DOUBLE PRECISION WNOR(5*N) DOUBLE PRECISION RNOR(N), CNOR(N) INTEGER COLIND(NZ),ROWIND(NZ) INTEGER J,I,K INTEGER MPRINT,MP,NSCA INTEGER IFAIL9 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0) DO 15 I=1,N RNOR(I) = ZERO CNOR(I) = ZERO 15 CONTINUE CALL DMUMPS_216(N,N,NZ,VAL,ROWIND,COLIND, & RNOR,CNOR,WNOR, MP,IFAIL9) *CVD$ NODEPCHK *CVD$ VECTOR *CVD$ CONCUR DO 30 I=1,N CNOR(I) = exp(CNOR(I)) RNOR(I) = exp(RNOR(I)) 30 CONTINUE IF ((NSCA.EQ.5).OR.(NSCA.EQ.6)) THEN DO 100 K=1,NZ I = ROWIND(K) J = COLIND(K) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 100 VAL(K) = VAL(K) * CNOR(J) * RNOR(I) 100 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING USING MC29' RETURN END SUBROUTINE DMUMPS_239 SUBROUTINE DMUMPS_241(N,NZ,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER N,NZ DOUBLE PRECISION VAL(NZ) DOUBLE PRECISION CNOR(N) DOUBLE PRECISION COLSCA(N) INTEGER IRN(NZ), ICN(NZ) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J,K DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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_241 SUBROUTINE DMUMPS_238(N,NZ,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER N, NZ DOUBLE PRECISION VAL(NZ) DOUBLE PRECISION ROWSCA(N),COLSCA(N) INTEGER IRN(NZ),ICN(NZ) DOUBLE PRECISION VDIAG INTEGER MPRINT,I,J,K 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 K=1,NZ I = IRN(K) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K) IF (I.EQ.J) THEN VDIAG = abs(VAL(K)) 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_238 SUBROUTINE DMUMPS_240(NSCA,N,NZ,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER N, NZ, NSCA INTEGER IRN(NZ), ICN(NZ) DOUBLE PRECISION VAL(NZ) DOUBLE PRECISION RNOR(N) DOUBLE PRECISION ROWSCA(N) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J,K DOUBLE PRECISION ZERO,ONE PARAMETER (ZERO=0.0D0, ONE=1.0D0) DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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 K=1,NZ I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K) = VAL(K) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE DMUMPS_240 SUBROUTINE DMUMPS_216(M,N,NE,A,IRN,ICN,R,C,W,LP,IFAIL) INTEGER M,N,NE DOUBLE PRECISION A(NE) INTEGER IRN(NE),ICN(NE) DOUBLE PRECISION R(M),C(N) DOUBLE PRECISION W(M*2+N*3) INTEGER LP,IFAIL INTRINSIC log,abs,min INTEGER MAXIT PARAMETER (MAXIT=100) DOUBLE PRECISION ONE DOUBLE PRECISION SMIN,ZERO PARAMETER (ONE=1.0D0,SMIN=0.1D0,ZERO=0.0D0) INTEGER I,I1,I2,I3,I4,I5,ITER,J,K DOUBLE PRECISION E,E1,EM,Q,Q1,QM,S,S1,SM,U,V IFAIL = 0 IF (M.LT.1 .OR. N.LT.1) THEN IFAIL = -1 GO TO 220 ELSE IF (NE.LE.0) THEN IFAIL = -2 GO TO 220 END IF I1 = 0 I2 = M I3 = M + N I4 = M + N*2 I5 = M + N*3 DO 10 I = 1,M R(I) = ZERO W(I1+I) = ZERO 10 CONTINUE DO 20 J = 1,N C(J) = ZERO W(I2+J) = ZERO W(I3+J) = ZERO W(I4+J) = ZERO 20 CONTINUE DO 30 K = 1,NE U = abs(A(K)) IF (U.EQ.ZERO) GO TO 30 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 30 U = log(U) W(I1+I) = W(I1+I) + ONE W(I2+J) = W(I2+J) + ONE R(I) = R(I) + U W(I3+J) = W(I3+J) + U 30 CONTINUE DO 40 I = 1,M IF (W(I1+I).EQ.ZERO) W(I1+I) = ONE R(I) = R(I)/W(I1+I) W(I5+I) = R(I) 40 CONTINUE DO 50 J = 1,N IF (W(I2+J).EQ.ZERO) W(I2+J) = ONE W(I3+J) = W(I3+J)/W(I2+J) 50 CONTINUE SM = SMIN*dble(NE) DO 60 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 60 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 60 R(I) = R(I) - W(I3+J)/W(I1+I) 60 CONTINUE E = ZERO Q = ONE S = ZERO DO 70 I = 1,M S = S + W(I1+I)*R(I)**2 70 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 160 DO 150 ITER = 1,MAXIT DO 80 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 80 J = ICN(K) I = IRN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 80 C(J) = C(J) + R(I) 80 CONTINUE S1 = S S = ZERO DO 90 J = 1,N V = -C(J)/Q C(J) = V/W(I2+J) S = S + V*C(J) 90 CONTINUE E1 = E E = Q*S/S1 Q = ONE - E IF (abs(S).LE.abs(SM)) E = ZERO DO 100 I = 1,M R(I) = R(I)*E*W(I1+I) 100 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 180 EM = E*E1 DO 110 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 110 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 110 R(I) = R(I) + C(J) 110 CONTINUE S1 = S S = ZERO DO 120 I = 1,M V = -R(I)/Q R(I) = V/W(I1+I) S = S + V*R(I) 120 CONTINUE E1 = E E = Q*S/S1 Q1 = Q Q = ONE - E IF (abs(S).LE.abs(SM)) Q = ONE QM = Q*Q1 DO 130 J = 1,N W(I4+J) = (EM*W(I4+J)+C(J))/QM W(I3+J) = W(I3+J) + W(I4+J) 130 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 160 DO 140 J = 1,N C(J) = C(J)*E*W(I2+J) 140 CONTINUE 150 CONTINUE 160 DO 170 I = 1,M R(I) = R(I)*W(I1+I) 170 CONTINUE 180 DO 190 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 190 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 190 R(I) = R(I) + W(I3+J) 190 CONTINUE DO 200 I = 1,M R(I) = R(I)/W(I1+I) - W(I5+I) 200 CONTINUE DO 210 J = 1,N C(J) = -W(I3+J) 210 CONTINUE RETURN 220 IF (LP.GT.0) WRITE (LP,'(/A/A,I3)') & ' **** Error return from DMUMPS_216 ****',' IFAIL =',IFAIL END SUBROUTINE DMUMPS_216 SUBROUTINE DMUMPS_27( 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_207(id%A(1), & id%NZ, id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL DMUMPS_289(id%A(1), & id%NZ, 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_119(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL DMUMPS_135(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, 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%NZ_loc .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL DMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1) ) ELSE CALL DMUMPS_289(id%A_loc(1), & id%NZ_loc, 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_27 SUBROUTINE DMUMPS_693(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, M, 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 RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) INTEGER ISZWRKRC DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION ONENORMERR,INFNORMERR INTEGER SYM, NB1, NB2, NB3 DOUBLE PRECISION EPS EXTERNAL DMUMPS_694,DMUMPS_687, & DMUMPS_670 INTEGER I IF(SYM.EQ.0) THEN CALL DMUMPS_694(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_687(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_693 SUBROUTINE DMUMPS_694(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, M, 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 RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) INTEGER ISZWRKRC DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION ONENORMERR,INFNORMERR INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC 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 INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS INTEGER ITER, NZIND, IR, IC DOUBLE PRECISION ELM 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) EXTERNAL DMUMPS_654, & DMUMPS_672, & DMUMPS_674, & DMUMPS_662, & DMUMPS_743, & DMUMPS_745, & DMUMPS_660, & DMUMPS_670, & DMUMPS_671, & DMUMPS_657, & DMUMPS_656 INTEGER DMUMPS_743 INTEGER DMUMPS_745 DOUBLE PRECISION DMUMPS_737 DOUBLE PRECISION DMUMPS_738 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) 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 IF(OP == 1) THEN IF(NUMPROCS > 1) THEN CALL DMUMPS_654(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ) CALL DMUMPS_654(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ) CALL DMUMPS_672(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_672(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_662(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 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0 ENDIF RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL RESZ = RESZR + RESZC 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 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 CALL DMUMPS_660(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 IRNGHBPRCS = IMYCPTR+ INUMMYC IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1 OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM OCSNDRCVJA = OCSNDRCVIA + NUMPROCS + 1 REQUESTS = OCSNDRCVJA + OCSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL DMUMPS_674(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_674(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_670(ROWSCA, M, RZERO) CALL DMUMPS_670(COLSCA, N, RZERO) CALL DMUMPS_671(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE) CALL DMUMPS_671(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE) ELSE CALL DMUMPS_670(ROWSCA, M, RONE) CALL DMUMPS_670(COLSCA, N, RONE) ENDIF ITDRPTR = 1 ITDCPTR = ITDRPTR + M ISRRPTR = ITDCPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL ISRCPTR = OSRRPTR + ORSNDRCVVOL OSRCPTR = ISRCPTR + ICSNDRCVVOL IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1 ISRCPTR = ISRCPTR - 1 OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) IF(NUMPROCS > 1) THEN CALL DMUMPS_650(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) CALL DMUMPS_650(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) ELSE CALL DMUMPS_670(WRKRC(ITDRPTR),M, RZERO) CALL DMUMPS_670(WRKRC(ITDCPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1,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_657(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) CALL DMUMPS_657(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_737(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) INFERRCOL = DMUMPS_737(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL DMUMPS_665(COLSCA, WRKRC(ITDCPTR), & N, & IWRK(IMYCPTR),INUMMYC) CALL DMUMPS_665(ROWSCA, WRKRC(ITDRPTR), & M, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = DMUMPS_738(ROWSCA, & WRKRC(ITDRPTR), M) INFERRCOL = DMUMPS_738(COLSCA, & WRKRC(ITDCPTR), N) INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL DMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL DMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE IF((ITER .EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1,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_656(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) CALL DMUMPS_656(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_737(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) ONEERRCOL = DMUMPS_737(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_665(COLSCA, WRKRC(ITDCPTR), & N, & IWRK(IMYCPTR),INUMMYC) CALL DMUMPS_665(ROWSCA, WRKRC(ITDRPTR), & M, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = DMUMPS_738(ROWSCA, & WRKRC(ITDRPTR), M) ONEERRCOL = DMUMPS_738(COLSCA, & WRKRC(ITDCPTR), N) ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL DMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL DMUMPS_665(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) CALL DMUMPS_665(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) ELSE CALL DMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL DMUMPS_666(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 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_694 SUBROUTINE DMUMPS_687(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, 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) INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ISRRPTR, OSRRPTR DOUBLE PRECISION ONENORMERR,INFNORMERR INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS INTEGER ITER, NZIND, IR, IC DOUBLE PRECISION ELM INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) EXTERNAL DMUMPS_655, & DMUMPS_673, & DMUMPS_692, & DMUMPS_663, & DMUMPS_742, & DMUMPS_745, & DMUMPS_661, & DMUMPS_657, & DMUMPS_656, & DMUMPS_670, & DMUMPS_671 INTEGER DMUMPS_742 INTEGER DMUMPS_745 DOUBLE PRECISION DMUMPS_737 DOUBLE PRECISION DMUMPS_738 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) 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 CALL DMUMPS_655(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ) CALL DMUMPS_673(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc,JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL DMUMPS_663(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWRKSZ) INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZ = INTSZR + N + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0 ENDIF RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) INUMMYR = REGISTRE(9) IF(NUMPROCS > 1) THEN CALL DMUMPS_661(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-INUMMYR) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 REQUESTS = ORSNDRCVJA + ORSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL DMUMPS_692(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_670(SCA, N, RZERO) CALL DMUMPS_671(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE) ELSE CALL DMUMPS_670(SCA, N, RONE) ENDIF ITDRPTR = 1 ISRRPTR = ITDRPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) IF(NUMPROCS > 1) THEN CALL DMUMPS_650(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL DMUMPS_670(WRKRC(ITDRPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1,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_657(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_737(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_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = DMUMPS_738(SCA, & WRKRC(ITDRPTR), N) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL DMUMPS_666(SCA, WRKRC(ITDRPTR), N) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1,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,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_656(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_737(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = DMUMPS_738(SCA, & WRKRC(ITDRPTR), N) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_666(SCA, WRKRC(ITDRPTR), N) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL DMUMPS_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL DMUMPS_666(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_687 SUBROUTINE DMUMPS_654(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL DMUMPS_703 INTEGER MYID, NUMPROCS, COMM INTEGER NZ_loc, ISZ, IWSZ, OSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWSZ) INCLUDE 'mpif.h' INTEGER I INTEGER OP, IERROR INTEGER IR, IC IF(NUMPROCS.NE.1) THEN CALL MPI_OP_CREATE(DMUMPS_703, .TRUE., OP, IERROR) CALL DMUMPS_668(IWRK, 4*ISZ, ISZ) DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_654 SUBROUTINE DMUMPS_662(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, M, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER INUMMYR, INUMMYC INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC INUMMYR = 0 INUMMYC = 0 DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRK(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I=1,NZ_loc IC = JCN_loc(I) IR = IRN_loc(I) 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 RETURN END SUBROUTINE DMUMPS_662 SUBROUTINE DMUMPS_660(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, 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 INTEGER I, IR, IC, ITMP, MAXMN MAXMN = M IF(N > MAXMN) MAXMN = N DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_660 INTEGER FUNCTION DMUMPS_744(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION EPS INTEGER I, IID DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) DMUMPS_744 = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN DMUMPS_744 = 0 ENDIF ENDDO RETURN END FUNCTION DMUMPS_744 INTEGER FUNCTION DMUMPS_745(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION EPS INTEGER I DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) DMUMPS_745 = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN DMUMPS_745 = 0 ENDIF ENDDO RETURN END FUNCTION DMUMPS_745 INTEGER FUNCTION DMUMPS_743(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_744 INTEGER DMUMPS_744 INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = DMUMPS_744(DR, M, INDXR, INDXRSZ, EPS) MYRESC = DMUMPS_744(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) DMUMPS_743 = GLORES RETURN END FUNCTION DMUMPS_743 DOUBLE PRECISION FUNCTION DMUMPS_737(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) 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_737 = ERRMAX RETURN END FUNCTION DMUMPS_737 DOUBLE PRECISION FUNCTION DMUMPS_738(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) 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_738 = ERRMAX1 RETURN END FUNCTION DMUMPS_738 SUBROUTINE DMUMPS_665(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt 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_665 SUBROUTINE DMUMPS_666(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTRINSIC sqrt 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_666 SUBROUTINE DMUMPS_671(D, DSZ, INDX, INDXSZ, VAL) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION VAL INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO RETURN END SUBROUTINE DMUMPS_671 SUBROUTINE DMUMPS_702(D, DSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = 1.0D0/D(IIND) ENDDO RETURN END SUBROUTINE DMUMPS_702 SUBROUTINE DMUMPS_670(D, DSZ, VAL) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION VAL INTEGER I DO I=1,DSZ D(I) = VAL ENDDO RETURN END SUBROUTINE DMUMPS_670 SUBROUTINE DMUMPS_650(TMPD, TMPSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER TMPSZ,INDXSZ DOUBLE PRECISION TMPD(TMPSZ) INTEGER INDX(INDXSZ) INTEGER I DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO RETURN END SUBROUTINE DMUMPS_650 SUBROUTINE DMUMPS_703(INV, INOUTV, LEN, DTYPE) IMPLICIT NONE INTEGER LEN INTEGER INV(2*LEN) INTEGER INOUTV(2*LEN) INTEGER DTYPE INTEGER I INTEGER DIN, DINOUT, PIN, PINOUT DO I=1,2*LEN-1,2 DIN = INV(I) PIN = INV(I+1) DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_703 SUBROUTINE DMUMPS_668(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER IWSZ INTEGER IW(IWSZ) INTEGER IVAL INTEGER I DO I=1,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE DMUMPS_668 SUBROUTINE DMUMPS_704(MYID, NUMPROCS, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRKROW, IWRKCOL, IWSZR, IWSZC, COMM ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, M, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(M) INTEGER MYCOLINDICES(N) INTEGER INUMMYR, INUMMYC INTEGER IWSZR, IWSZC INTEGER IWRKROW(IWSZR) INTEGER IWRKCOL(IWSZC) INTEGER COMM INTEGER I, IR, IC, ITMP INUMMYR = 0 INUMMYC = 0 DO I=1,M IWRKROW(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRKROW(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRKROW(IR) .EQ. 0) THEN IWRKROW(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO ITMP = 1 DO I=1,M IF(IWRKROW(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO DO I=1,N IWRKCOL(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRKCOL(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRKCOL(IC) .EQ. 0) THEN IWRKCOL(IC)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDIF ENDDO ITMP = 1 DO I=1,N IF(IWRKCOL(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_704 SUBROUTINE DMUMPS_672(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ, OSZ INTEGER ISNDRCVNUM, ISNDRCVVOL INTEGER OSNDRCVNUM, OSNDRCVVOL INTEGER COMM INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWRKSZ) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INCLUDE 'mpif.h' INTEGER I INTEGER IIND, IIND2, PIND INTEGER IERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO DO I=1,NZ_loc IIND = INDX(I) IIND2 = OINDX(I) 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 IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 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_672 SUBROUTINE DMUMPS_674(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 MYID, NUMPROCS, NZ_loc, ISZ, ISNDVOL, OSNDVOL, OSZ INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) 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 INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR DO I=1,ISZ IWRK(I) = 0 ENDDO 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 DO I=1,NZ_loc IIND=INDX(I) IIND2 = OINDX(I) 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 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_674 SUBROUTINE DMUMPS_657(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 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 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 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_657 SUBROUTINE DMUMPS_656(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 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 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 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_656 SUBROUTINE DMUMPS_655(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL DMUMPS_703 INTEGER MYID, NUMPROCS, COMM INTEGER NZ_loc, ISZ, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWSZ) INCLUDE 'mpif.h' INTEGER I INTEGER OP, IERROR INTEGER IR, IC IF(NUMPROCS.NE.1) THEN CALL MPI_OP_CREATE(DMUMPS_703, .TRUE., OP, IERROR) CALL DMUMPS_668(IWRK, 4*ISZ, ISZ) DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_655 SUBROUTINE DMUMPS_673(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ INTEGER ISNDRCVNUM, ISNDRCVVOL INTEGER OSNDRCVNUM, OSNDRCVVOL INTEGER COMM INTEGER INDX(NZ_loc), OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWRKSZ) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INCLUDE 'mpif.h' INTEGER I INTEGER IIND, IIND2, PIND INTEGER IERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO DO I=1,NZ_loc IIND = INDX(I) IIND2 = OINDX(I) 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 IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I) 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 CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 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_673 SUBROUTINE DMUMPS_663(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER INUMMYR INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC INUMMYR = 0 DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 RETURN END SUBROUTINE DMUMPS_663 INTEGER FUNCTION DMUMPS_742(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_744 INTEGER DMUMPS_744 INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = DMUMPS_744(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) DMUMPS_742 = GLORES RETURN END FUNCTION DMUMPS_742 SUBROUTINE DMUMPS_661(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, N INTEGER INUMMYR, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC, ITMP, MAXMN MAXMN = N DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_661 SUBROUTINE DMUMPS_692(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, NZ_loc, ISZ, ISNDVOL, OSNDVOL INTEGER INDX(NZ_loc), OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) 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 INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR DO I=1,ISZ IWRK(I) = 0 ENDDO 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 DO I=1,NZ_loc IIND=INDX(I) IIND2 = OINDX(I) 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(I) 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 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_692 SUBROUTINE DMUMPS_628(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_628 SUBROUTINE DMUMPS_629 &(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_729( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE DMUMPS_629 SUBROUTINE DMUMPS_630(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_630 SUBROUTINE DMUMPS_631(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_631 SUBROUTINE DMUMPS_94(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE) 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) 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 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) RETURN 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_629(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_729(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_630(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_631(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_94" ENDIF IF (RBEGCONTIG > 0_8) GOTO 25 CALL DMUMPS_629 & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL DMUMPS_628(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL DMUMPS_627(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_627(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_729(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL DMUMPS_631(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_724(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_729( 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_94" 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 RETURN END SUBROUTINE DMUMPS_94 SUBROUTINE DMUMPS_632(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_729(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_632 SUBROUTINE DMUMPS_627(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_627" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in DMUMPS_627" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in DMUMPS_627",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_627 SUBROUTINE DMUMPS_700(BUFR,LBUFR, & LBUFR_BYTES, & root, N, IW, LIW, A, LA, & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, 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) 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_S(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 ), PTRAIW(N), PTRARW( N ) INTEGER INTARR(max(1,KEEP(14))) DOUBLE PRECISION DBLARR(max(1,KEEP(13))) INCLUDE 'mpif.h' INTEGER IERR 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_S( 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 ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_681(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL DMUMPS_580(IERR) ENDIF CALL DMUMPS_507( 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_500( & 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 ENDIF IF (KEEP(60) == 0) THEN CALL DMUMPS_284( 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, 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_S(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST_S(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_700' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_38( 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 CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) 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_700' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL DMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_38( 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_38( 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 CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) ENDIF RETURN END SUBROUTINE DMUMPS_700 SUBROUTINE DMUMPS_762(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_762 SUBROUTINE DMUMPS_761(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_761 SUBROUTINE DMUMPS_763(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_762(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_763 SUBROUTINE DMUMPS_764( & 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_771 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_771, & .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_764 SUBROUTINE DMUMPS_771(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE INTEGER, INTENT(IN) :: NEL, DATATYPE 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_762(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = dble(TMPEXPINOUT) ENDDO RETURN END SUBROUTINE DMUMPS_771 SUBROUTINE DMUMPS_765(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE DMUMPS_765 SUBROUTINE DMUMPS_766(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER DETER=1.0D0/DETER NEXP=-NEXP RETURN END SUBROUTINE DMUMPS_766 SUBROUTINE DMUMPS_767(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_767 SUBROUTINE DMUMPS_224(NFRONT,NASS,IBEGKJI, LPIV, TIPIV, & 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER IBEGKJI, LPIV INTEGER TIPIV(LPIV) INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW DOUBLE PRECISION UU, SEUIL 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(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U DOUBLE PRECISION SWOP INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3_8 INTEGER(8) :: NFRONT8 INTEGER ILOC DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) DOUBLE PRECISION RZERO, RMAX, AMROW, ONE DOUBLE PRECISION PIVNUL DOUBLE PRECISION FIXA, CSEUIL INTEGER NPIV,NASSW,IPIV INTEGER NPIVP1,JMAX,J3,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF INCLUDE 'mumps_headers.h' INTEGER DMUMPS_IXAMAX INTRINSIC max DATA RZERO /0.0D0/ DATA ONE /1.0D0/ INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER XSIZE PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL NFRONT8=int(NFRONT,8) 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_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL DMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ILOC = NPIVP1 - IBEGKJI + 1 TIPIV(ILOC) = ILOC NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_680( 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 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF (UU.GT.RZERO) GO TO 340 IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 340 AMROW = RZERO J1 = APOS J2 = APOS +int(- NPIV + NASS - 1,8) J3 = NASS -NPIV JMAX = DMUMPS_IXAMAX(J3,A(J1),1) JJ = int(JMAX,8) + J1 - 1_8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = J2 + 1_8 J2 = APOS +int(- NPIV + NFRONT - KEEP(253)- 1,8) IF (J2.LT.J1) GO TO 370 DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF (RMAX.LE.PIVNUL) THEN KEEP(109) = KEEP(109)+1 ISW = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6+KEEP(IXSZ)+ & IW(IOLDPS+5+KEEP(IXSZ))+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 - KEEP(253) - 1,8) DO JJ=J1,J2 A(JJ)= ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF IF (abs(A(IDIAG)).GT.max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE.max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258).NE.0) THEN CALL DMUMPS_762( 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_8 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3_8) A(J3_8) = SWOP J3_8 = J3_8 + 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) TIPIV(ILOC) = ILOC + JMAX - 1 J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,NASS 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 (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 WRITE(*,*) 'NIV2:Detected 0 pivot, INODE,NPIV=',INODE,NPIV GOTO 430 420 CONTINUE IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_680( 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_224 SUBROUTINE DMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & IW, LIW, & IOLDPS, POSELT, A, LA, LDA_FS, & IBEGKJI, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEGKJI, 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) 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), & PTRARW(LPTRAR), PTRAIW(LPTRAR), & ND( KEEP(28) ), FRERE( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) 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(max(1,KEEP(13))) EXTERNAL DMUMPS_329 INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES 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_294 ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEGKJI + 1 NCOL = LDA_FS - IBEGKJI + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEGKJI-1,8) + & int(IBEGKJI - 1,8) IF (IBEGKJI > 0) THEN CALL MUMPS_511( LDA_FS, IBEGKJI-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_511( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL DMUMPS_190(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTBL)) ) THEN PDEST = IOLDPS + 6 + KEEP(IXSZ) IERR = -1 IF ( NPIV .NE. 0 ) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF DO WHILE (IERR .EQ.-1) CALL DMUMPS_65( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTBL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP(50), NB_BLOC_FAC, & COMM, IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF (MESSAGE_RECEIVED) POSELT = PTRAST(STEP(INODE)) 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 CALL MUMPS_731( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL DMUMPS_44( MYID, SLAVEF, COMM ) 500 RETURN END SUBROUTINE DMUMPS_294 SUBROUTINE DMUMPS_273( 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, & 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) 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_330 EXTERNAL MUMPS_330 IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_330(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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_273', & ' 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_507(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE DMUMPS_273 SUBROUTINE DMUMPS_363(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_275 INTEGER MUMPS_275 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_170,MUMPS_167 LOGICAL MUMPS_170,MUMPS_167 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_363",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_363' 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_363' 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_363' 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_363' 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_363' 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_363' 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_462(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_363' 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_170(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_170(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_170(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_170(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_462(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_462(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_462(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(*,*)'Probleme dans reorder!!!!' 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_462(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_511(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_167(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_170( & 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_511(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_170( & PROCNODE(STEP(INODE)),SLAVEF)))THEN CALL DMUMPS_462(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_363 SUBROUTINE DMUMPS_364(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_283,MUMPS_275 LOGICAL MUMPS_283 INTEGER MUMPS_275 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 INDICE(SLAVEF),ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_170,MUMPS_167 LOGICAL MUMPS_170,MUMPS_167 DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK 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 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_363",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)) RETURN 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_363' 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_363' 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_363' 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_363' 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_462(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_363' 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_167(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_283(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_167(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_511(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_167(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_283(PROCNODE(STEP(INODE)),SLAVEF))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_275(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_275(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_167(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_275(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_170(PROCNODE(STEP(INODE)), & SLAVEF))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_283(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) 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_364 RECURSIVE SUBROUTINE DMUMPS_462(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_462(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL DMUMPS_462(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_462 mumps-4.10.0.dfsg/src/zmumps_part6.F0000644000175300017530000046706611562233070017470 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE ZMUMPS_324(A, LDA, NPIV, NBROW, K50 ) IMPLICIT NONE INTEGER LDA, NPIV, NBROW, K50 COMPLEX(kind=8) A(int(LDA,8)*int(NBROW+NPIV,8)) 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_324 SUBROUTINE ZMUMPS_651(A, LDA, NPIV, NCONTIG ) IMPLICIT NONE INTEGER NCONTIG, NPIV, LDA COMPLEX(kind=8) A(NCONTIG*LDA) 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_651 SUBROUTINE ZMUMPS_652( 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(ALLOW_NON_INIT) 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(ALLOW_NON_INIT) 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_652 SUBROUTINE ZMUMPS_705( 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(ALLOW_NON_INIT) 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) 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(ALLOW_NON_INIT) IF (.NOT. COMPRESSCB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_705 SUBROUTINE ZMUMPS_140( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, & UU, NNEG, NPVW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS ) USE ZMUMPS_OOC IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, 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(30) INTEGER INOPV, IFINB, NFRONT, NPIV, NBOLKJ, & NBTLKJ,IBEG_BLOCK INTEGER NASS, NEL1, IFLAG_OOC INTEGER :: LDA DOUBLE PRECISION UUTEMP INCLUDE 'mumps_headers.h' EXTERNAL ZMUMPS_222, ZMUMPS_234, & ZMUMPS_230, ZMUMPS_226, & ZMUMPS_237 LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVSIZ,IWPOSP2 INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY LOGICAL POSTPONE_COL_UPDATE, IS_MAXFROMM_AVAIL DOUBLE PRECISION MAXFROMM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L INTEGER PP_LastPIVRPTRFilled IS_MAXFROMM_AVAIL = .FALSE. 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 POSTPONE_COL_UPDATE = (UUTEMP == 0.0D0 .AND. KEEP(201).NE.1) IBEG_BLOCK = 1 NFRONT = IW(IOLDPS+KEEP(IXSZ)) LDA = NFRONT NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IF (KEEP(201).EQ.1) THEN IDUMMY = -8765 CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L 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+KEEP(IXSZ): & IOLDPS+5+NFRONT+KEEP(IXSZ)+NFRONT) ENDIF IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) UUTEMP = UU 50 CONTINUE CALL ZMUMPS_222(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & INOPV, NNEG, IFLAG,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, KEEP(IXSZ), & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL) 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+KEEP(IXSZ))+6+KEEP(IXSZ) & +IW(IOLDPS+5+KEEP(IXSZ)) PIVNUL_LIST(KEEP(109)) = IW(IWPOSP2) ENDIF ENDIF IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF CALL ZMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, POSTPONE_COL_UPDATE, & ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG) GOTO 500 END IF IF (INOPV.EQ.2) THEN CALL ZMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), & POSTPONE_COL_UPDATE, & KEEP,KEEP8) GOTO 50 ENDIF NPVW = NPVW + PIVSIZ IF (NASS.LE.1) THEN CALL ZMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 GO TO 500 ENDIF CALL ZMUMPS_226(IBEG_BLOCK, & NFRONT, NASS, N,INODE,IW,LIW,A,LA, & LDA, POSTPONE_COL_UPDATE, IOLDPS, & POSELT,IFINB, & NBTLKJ,PIVSIZ, KEEP(IXSZ),MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0D0), & KEEP(253) ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6 IW(IWPOSP2+NFRONT+KEEP(IXSZ)) = -IW(IWPOSP2+NFRONT+KEEP(IXSZ)) ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ IF (IFINB.EQ.0) GOTO 50 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV IF (KEEP(201).EQ.1) THEN IF (IFINB.EQ.-1) THEN MonBloc%Last = .TRUE. ELSE MonBloc%Last = .FALSE. ENDIF MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_688( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG .LT. 0 ) RETURN ENDIF CALL ZMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), & POSTPONE_COL_UPDATE, & KEEP,KEEP8) IF (IFINB.EQ.-1) THEN CALL ZMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG) & GOTO 500 ENDIF GO TO 50 500 CONTINUE IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) LAST_CALL=.TRUE. CALL ZMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG < 0 ) RETURN CALL ZMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE ZMUMPS_140 SUBROUTINE ZMUMPS_222 & (NFRONT,NASS,N,INODE,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) #if defined (PROFILE_BLAS_ASS_G) USE ZMUMPS_LOAD #endif USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV, & IOLDPS, NNEG 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(30) 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 DOUBLE PRECISION RMAX,AMAX,TMAX,TOL DOUBLE PRECISION MAXPIV DOUBLE PRECISION PIVNUL COMPLEX(kind=8) FIXA, CSEUIL COMPLEX(kind=8) PIVOT,DETPIV PARAMETER(TOL = 1.0D-20) 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,NASSW,IPIV INTEGER NPIVP1,K 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) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL ZMUMPS_667(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 NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL ZMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO) THEN IF (abs(A(APOS)).EQ.RZERO) GO TO 630 IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF GO TO 420 ENDIF AMAX = RZERO JMAX = 0 IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM > PIVNUL .AND. abs(PIVOT) > TOL) THEN IF ( abs(PIVOT) .GT. max(UULOC*MAXFROMM,SEUIL) ) THEN IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, NASSW - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 IF ( (NFRONT - KEEP(253) - NASSW).GE.300 ) THEN OMP_FLAG = .TRUE. ELSE OMP_FLAG = .FALSE. ENDIF DO J=1, NFRONT - KEEP(253) - NASSW J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO 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, NASSW - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,NFRONT - NASSW A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN IF(SEUIL .GT. epsilon(SEUIL)) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL ENDIF PIVOT = A(POSPV1) KEEP(98) = KEEP(98)+1 GO TO 415 ENDIF ENDIF ENDIF IF (max(AMAX,abs(PIVOT)).LE.TOL) GO TO 460 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (AMAX.LE.TOL) GO TO 460 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 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 = (NFRONT-JMAX-KEEP(253). GE. 300) DO K = 1, NFRONT - JMAX - KEEP(253) JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 OMP_FLAG = (NFRONT-JMAX-KEEP(253). GE. 300) DO K = 1, NFRONT-JMAX-KEEP(253) JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO 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 ) GOTO 460 ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_762(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(103) = KEEP(103)+1 415 CONTINUE 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) THEN GOTO 416 ENDIF CALL ZMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDA, NFRONT, 1, KEEP(219), KEEP(50), & KEEP(IXSZ)) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL ZMUMPS_680( 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 (NASSW.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_222 SUBROUTINE ZMUMPS_680( 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_680!" 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_680 SUBROUTINE ZMUMPS_226(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW, & A,LA,LDA, POSTPONE_COL_UPDATE, & IOLDPS,POSELT,IFINB,LKJIB,PIVSIZ,XSIZE, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & KEEP253) IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB, & NPBEG, IBEG_BLOCK INTEGER LDA INTEGER(8) :: LA INTEGER(8) :: NFRONT8 COMPLEX(kind=8) A(LA) LOGICAL POSTPONE_COL_UPDATE INTEGER IW(LIW) COMPLEX(kind=8) VALPIV 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 :: MAXFROMMTMP INTEGER IOLDPS, NCB1 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NPIV,JROW2 INTEGER NEL2,NEL INTEGER XSIZE COMPLEX(kind=8) ONE, ZERO 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 = IW(IOLDPS+1+XSIZE) NPIV_NEW = NPIV + PIVSIZ NEL = NFRONT - NPIV_NEW IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. JROW2 = IW(IOLDPS+3+XSIZE) NPBEG = IBEG_BLOCK NEL2 = JROW2 - NPIV_NEW IF (NEL2.EQ.0) THEN IF (JROW2.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) A(APOS) = VALPIV 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 (POSTPONE_COL_UPDATE) THEN NCB1 = NASS - JROW2 ELSE NCB1 = NFRONT - JROW2 ENDIF IF (.NOT. IS_MAX_USEFUL) THEN 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 ELSE MAXFROMMTMP=0.0D0 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 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 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) A(POSPV2) = A(POSPV1)/DETPIV A(POSPV1) = SWOP/DETPIV A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL zcopy(NFRONT-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL zcopy(NFRONT-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 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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 = JROW2+1,NFRONT K1 = JJ K2 = JJ+1_8 MULT1 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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_226 SUBROUTINE ZMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT) IMPLICIT NONE INTEGER NFRONT,N,INODE,LIW INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) COMPLEX(kind=8) VALPIV INTEGER (8) :: APOS, POSELT, LPOS, NFRONT8 INTEGER IOLDPS,NEL INTEGER JROW COMPLEX(kind=8), PARAMETER :: ONE = (1.0D0,0.0D0) APOS = POSELT VALPIV = ONE/A(APOS) A(APOS) = VALPIV NEL = NFRONT - 1 IF (NEL.EQ.0) GO TO 500 NFRONT8 = int(NFRONT,8) LPOS = APOS + NFRONT8 CALL ZMUMPS_XSYR('U',NEL, -VALPIV, & A(LPOS), NFRONT, A(LPOS+1_8), NFRONT) DO JROW = 1,NEL A(LPOS) = VALPIV*A(LPOS) LPOS = LPOS + NFRONT8 END DO 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_230 SUBROUTINE ZMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT, & POSTPONE_COL_UPDATE, & KEEP,KEEP8 ) IMPLICIT NONE INTEGER NFRONT, NASS,N,LIW, IBEG_BLOCK INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER(8) :: LDA8 INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1, NEL11 INTEGER LBP, HF INTEGER(8) :: LPOS,UPOS,APOS INTEGER LKJIT INTEGER LKJIBOLD, IROW INTEGER I, Block INTEGER BLSIZE LOGICAL POSTPONE_COL_UPDATE COMPLEX(kind=8) ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) LDA8 = int(LDA,8) LKJIBOLD = LKJIB NPIV = IW(IOLDPS+1+KEEP(IXSZ)) JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 NEL11 = NFRONT - NPIV IF ( LKJIW .NE. LKJIB ) THEN NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) LKJIB = min0(LKJIB, NASS - NPIV) ELSE LKJIB = NASS - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = NASS ENDIF IBEG_BLOCK = NPIV + 1 ELSEIF (JROW2.LT.NASS) THEN IBEG_BLOCK = NPIV + 1 IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) LKJIB = min0(LKJIB,NASS-NPIV) ENDIF IF (LKJIW.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF ( NASS - JROW2 > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NASS - JROW2 END IF IF ( NASS - JROW2 .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int(IROW - 1,8) APOS = POSELT + int(IROW - 1,8) * LDA8 + int(JROW2,8) CALL zgemm( 'N','N', IROW + Block - JROW2 - 1, Block, LKJIW, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ENDDO #else DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL zgemm( 'N','N', Block, NASS - IROW + 1, LKJIW, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF LPOS = POSELT + int(NASS,8)*LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG-1,8) * LDA8 + int(JROW2,8) APOS = POSELT + int(NASS,8)*LDA8 + int(JROW2,8) IF ( .NOT. POSTPONE_COL_UPDATE ) THEN CALL zgemm('N', 'N', NEL1, NFRONT-NASS, LKJIW, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) END IF ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_234 SUBROUTINE ZMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, NASS, & LDA, NFRONT, LEVEL, K219, K50, XSIZE ) 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 ) INCLUDE 'mumps_headers.h' 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 CALL zswap( NPIVP1 - 1, & A( POSELT + int(NPIVP1-1,8) ), LDA, & A( POSELT + int(IPIV-1,8) ), LDA ) END IF CALL zswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL zswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP CALL zswap( NASS - IPIV, A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF ( LEVEL .eq. 1 ) THEN CALL zswap( NFRONT - NASS, & A( APOS + int(NASS-IPIV+1,8) * LDA8 ), LDA, & A( IDIAG + int(NASS-IPIV+1,8) * LDA8 ), LDA ) END IF 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_319 SUBROUTINE ZMUMPS_237(NFRONT,NASS,N,INODE, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG & ) USE ZMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,N,INODE,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 INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, I, IROWEND INTEGER I2, I2END, Block2 COMPLEX(kind=8) ONE, ALPHA, BETA, ZERO PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(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 DO I = 1, NPIV CALL zcopy( Block, A( LPOS+int(I-1,8) ), LDA, & A( UPOS+int(I-1,8)*LDA8 ), 1 ) CALL zscal( Block, A(POSELT+(LDA8+1_8)*int(I-1,8)), & A( LPOS + int(I - 1,8) ), LDA ) 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_688( & 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_237 SUBROUTINE ZMUMPS_320( 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_327( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL ZMUMPS_326( & 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_293( 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_281( 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_320 SUBROUTINE ZMUMPS_293( 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_293 SUBROUTINE ZMUMPS_281( 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_281 SUBROUTINE ZMUMPS_327( 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_327 SUBROUTINE ZMUMPS_326( 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_326 RECURSIVE SUBROUTINE ZMUMPS_274( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD USE ZMUMPS_OOC IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 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 PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) 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 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL 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 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 MUMPS_275 EXTERNAL MUMPS_275 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 FPERE = -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 ) LAELL = int(NPIV,8) * int(NCOL,8) 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_731(LAELL-LRLUS, IERROR) IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN ZMUMPS_274, & REAL WORKSPACE TOO SMALL" GOTO 700 END IF CALL ZMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731(LAELL-LRLUS,IERROR) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN ZMUMPS_274, & INTEGER WORKSPACE TOO SMALL" IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL ENDIF KEEP8(67) = min(LRLUS, KEEP8(67)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) IF ( NPIV.GT.0 ) THEN IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, MPI_DOUBLE_COMPLEX, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF DO WHILE ( NBPROCFILS(STEP(INODE)) .NE. 0 ) BLOCKING = .TRUE. SET_IRECV=.FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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)) 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 ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN ZMUMPS_274" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF 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_274" 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 CALL ztrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), NCOL, & A(POSELT+int(NPIV1,8)), NCOL1 ) 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 LPOS = POSELT + int(NPIV1,8) DPOS = POSBLOCFACTO I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(IPIV+I-1) .GT. 0) THEN CALL zscal( NROW1, A(DPOS), A(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(NCOL + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(NCOL + 1,8) OFFDAG = POSPV1+1_8 LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A(POSPV1)*A(LPOS1)+A(OFFDAG)*A(LPOS1+1_8) MULT2 = A(OFFDAG)*A(LPOS1)+A(POSPV2)*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(NCOL + 1,8) I = I+2 ENDIF ENDDO ENDIF 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 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL ZMUMPS_688( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN 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 FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * NCOL - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL ZMUMPS_190( 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)) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 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_64( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, IERR ) IF (IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & ZMUMPS_274" 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_274" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( NPIV .NE. 0 ) DEALLOCATE( UIP21K ) IOLDPS = PTRIST(STEP(INODE)) IF (LASTBL) THEN IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) - & TO_UPDATE_CPT_END 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_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL ZMUMPS_62( INODE, DEST, END_NIV2_LDLT, & COMM, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF END IF IF (LASTBL) THEN IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN CALL ZMUMPS_759( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE ZMUMPS_274 RECURSIVE SUBROUTINE ZMUMPS_759( & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE ZMUMPS_LOAD 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) 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_S(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 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 (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+XXS)=S_ALL IF (KEEP(214).EQ.1) THEN CALL ZMUMPS_314( 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, 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 CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) ENDIF ENDIF IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN CALL ZMUMPS_627(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_80( 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_S, COMP, IFLAG, IERROR, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, .FALSE., ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL ZMUMPS_314( 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, ITYPE2 & ) ENDIF CALL ZMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL ZMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP & ) 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_628( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) IF (KEEP(216).EQ.2) THEN CALL ZMUMPS_627(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 RETURN END SUBROUTINE ZMUMPS_759 SUBROUTINE ZMUMPS_141( 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 ) USE ZMUMPS_OOC IMPLICIT NONE INCLUDE 'zmumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW INTEGER(8) :: LA COMPLEX(kind=8) A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, SLAVEF, & IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IW( LIW ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), ITLOC(N+KEEP(253)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER PTRARW(LPTRAR), PTRAIW(LPTRAR), ND( KEEP(28) ) INTEGER FRERE(KEEP(28)), FILS(N) INTEGER INTARR(max(1,KEEP(14))) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), & PTLUST_S(KEEP(28)), & & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), NBPROCFILS(KEEP(28)), & PROCNODE_STEPS(KEEP(28)), STEP(N) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INTEGER(8) :: POSELT INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, NBTLKJ INTEGER NASS, IEND, IOLDPS, LDAFS,allocok, IBEG_BLOCK LOGICAL LASTBL LOGICAL RESET_TO_ONE, TO_UPDATE INTEGER K109_ON_ENTRY INTEGER I,J,JJ,K,IDEB DOUBLE PRECISION UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled EXTERNAL ZMUMPS_223, ZMUMPS_235, & ZMUMPS_227, ZMUMPS_294, & ZMUMPS_44 LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVSIZ,IWPOSPIV COMPLEX(kind=8) ONE PARAMETER (ONE=(1.0D0,0.0D0)) INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0D0)) IF (RESET_TO_ONE) THEN K109_ON_ENTRY = KEEP(109) ENDIF IBEG_BLOCK=1 NB_BLOC_FAC = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST( STEP( INODE )) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) LDAFS = NASS IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) IF (KEEP(201).EQ.1) THEN IDUMMY = -9876 CALL MUMPS_729(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+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ)) & :IOLDPS+5+2*NFRONT+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))) ENDIF ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, & ' integers' IFLAG=-13 IERROR=NASS GO TO 490 END IF 50 CONTINUE IBEGKJI = IBEG_BLOCK CALL ZMUMPS_223( & NFRONT,NASS,IBEGKJI, 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) 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+KEEP(IXSZ))+6 & +IW(IOLDPS+5+KEEP(IXSZ)) PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+KEEP(IXSZ)) ENDIF ENDIF IF(INOPV.EQ. 1 .AND. STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF IF (INOPV.GE.1) THEN LASTBL = (INOPV.EQ.1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL ZMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEGKJI, IEND, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (INOPV.EQ.1) GO TO 500 IF (INOPV.EQ.2) THEN CALL ZMUMPS_235(IBEG_BLOCK, & NASS,N,INODE,IW,LIW,A,LA, & LDAFS, & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP,KEEP8) GOTO 50 ENDIF NPVW = NPVW + PIVSIZ IF (NASS.LE.1) THEN IFINB = -1 IF (NASS == 1) A(POSELT)=ONE/A(POSELT) ELSE CALL ZMUMPS_227(IBEG_BLOCK, & NASS, N,INODE,IW,LIW,A,LA, & LDAFS, IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),PIVSIZ,KEEP(IXSZ)) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+1+KEEP(IXSZ))+6+ & IW(IOLDPS+5+KEEP(IXSZ)) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ IF (IFINB.EQ.0) GOTO 50 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN LASTBL = (IFINB.EQ.-1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL ZMUMPS_294(COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEGKJI, IEND, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (IFINB.EQ.(-1)) GOTO 500 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IF (KEEP(201).EQ.1) THEN IF (.NOT.RESET_TO_ONE.OR.K109_ON_ENTRY.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_688( & 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 CALL ZMUMPS_235(IBEG_BLOCK, & NASS,N,INODE,IW,LIW,A,LA, & LDAFS, & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP,KEEP8) IF (KEEP(201).EQ.1) THEN IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 JJ= IDEB TO_UPDATE=.FALSE. DO K = K109_ON_ENTRY+1, KEEP(109) I = PIVNUL_LIST(K) DO J=JJ,JJ+NASS IF (IW(J).EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN JJ= J J = J-IDEB+1 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE TO_UPDATE=.FALSE. ELSE IF (ICNTL(1).GT.0) THEN write(ICNTL(1),*) ' Internal error related ', & 'to null pivot row detection' ENDIF EXIT ENDIF ENDDO ENDIF K109_ON_ENTRY = KEEP(109) MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_688( & 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 GO TO 50 490 CONTINUE CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 JJ= IDEB TO_UPDATE=.FALSE. DO K = K109_ON_ENTRY+1, KEEP(109) I = PIVNUL_LIST(K) DO J=JJ,JJ+NASS IF (IW(J).EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN JJ= J J = J-IDEB+1 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE TO_UPDATE=.FALSE. ELSE IF (ICNTL(1).GT.0) THEN write(ICNTL(1),*) ' Internal error related ', & 'to null pivot row detection' ENDIF EXIT ENDIF ENDDO ENDIF IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) LAST_CALL = .TRUE. CALL ZMUMPS_688 & ( STRAT, 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 CALL ZMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE ZMUMPS_141 SUBROUTINE ZMUMPS_223( NFRONT, NASS, & IBEGKJI, 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV INTEGER NASS2, IBEGKJI, NNEG INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV 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(30) 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,TOL DOUBLE PRECISION MAXPIV COMPLEX(kind=8) PIVOT,DETPIV PARAMETER(TOL = 1.0D-20) INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK 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,NASSW,IPIV INTEGER NPIVP1,ILOC,K,J INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L 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_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEGKJI + 1 TIPIV( ILOC ) = ILOC NASSW = iabs(IW(IOLDPS+3+KEEP(IXSZ))) 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_762( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL ZMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO) THEN IF (abs(A(APOS)).EQ.RZERO) GO TO 630 IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF GO TO 420 ENDIF AMAX = RZERO 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, NASSW - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = max(abs(A(J1)),AMAX) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO IF (KEEP(219).NE.0) THEN RMAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX = RZERO ENDIF DO J=1,NASS - NASSW RMAX = max(abs(A(J1)),RMAX) J1 = J1 + LDAFS8 ENDDO 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, NASSW - IPIV A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO DO J=1,NASS - NASSW 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) GO TO 415 ENDIF IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN IF(SEUIL .GT. epsilon(SEUIL)) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL ENDIF PIVOT = A(POSPV1) WRITE(*,*) 'WARNING matrix may be singular' KEEP(98) = KEEP(98)+1 GO TO 415 ENDIF ENDIF ENDIF IF (max(AMAX,abs(PIVOT)) .LE. TOL) GOTO 460 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (AMAX.LE.TOL) GO TO 460 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 + LDAFS8 DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDAFS8 ENDDO 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 IF (KEEP(219).NE.0) THEN TMAX = max(SEUIL/UULOC,dble(A(APOSMAX+int(JMAX,8)))) ELSE TMAX = SEUIL/UULOC ENDIF IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+int(NASS,8) IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+int(NASS,8) TMAX=max(TMAX,abs(A(JJ))) ENDDO 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 ) GOTO 460 ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF (KEEP(258).NE.0) THEN CALL ZMUMPS_762(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(105) = KEEP(105)+1 415 CONTINUE DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEGKJI + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEGKJI + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEGKJI + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF CALL ZMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, KEEP(219), KEEP(50), & KEEP(IXSZ)) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL ZMUMPS_680( 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 (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE RETURN END SUBROUTINE ZMUMPS_223 SUBROUTINE ZMUMPS_235( & IBEG_BLOCK, & NASS, N, INODE, & IW, LIW, A, LA, & LDAFS, & IOLDPS, POSELT, & LKJIB_ORIG, LKJIB, LKJIT, KEEP,KEEP8 ) IMPLICIT NONE INTEGER NASS,N,LIW INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER (8) :: POSELT INTEGER (8) :: LDAFS8 INTEGER LDAFS, IBEG_BLOCK INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1 INTEGER HF INTEGER(8) :: LPOS,UPOS,APOS INTEGER LKJIT INTEGER LKJIBOLD, IROW INTEGER J, Block INTEGER BLSIZE COMPLEX(kind=8) ONE, ALPHA PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) LKJIBOLD = LKJIB NPIV = IW(IOLDPS+1+KEEP(IXSZ)) JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 IF ( LKJIW .NE. LKJIB ) THEN NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) LKJIB = min0(LKJIB, NASS - NPIV) ELSE LKJIB = NASS - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = NASS ENDIF ELSEIF (JROW2.LT.NASS) THEN IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) ENDIF IBEG_BLOCK = NPIV + 1 IF (LKJIW.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF ( NASS - JROW2 > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NASS - JROW2 END IF IF ( NASS - JROW2 .GT. 0 ) THEN DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDAFS8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDAFS8 + int(IROW - 1,8) APOS = POSELT + int(IROW-1,8) * LDAFS8 + int(IROW - 1,8) DO J=1, Block CALL zgemv( 'T', LKJIW, Block - J + 1, ALPHA, & A( LPOS ), LDAFS, A( UPOS ), LDAFS, & ONE, A( APOS ), LDAFS ) LPOS = LPOS + LDAFS8 APOS = APOS + LDAFS8 + 1_8 UPOS = UPOS + 1_8 END DO LPOS = POSELT + int(IROW-1+Block,8) * LDAFS8 & + int(NPBEG-1,8) UPOS = POSELT + int(NPBEG-1,8) * LDAFS8 + int(IROW-1,8) APOS = POSELT + int( IROW - 1 + Block,8 ) * LDAFS8 & + int(IROW - 1,8) CALL zgemm( 'N','N', Block, NASS - IROW + 1 - Block, LKJIW, & ALPHA, A( UPOS ), LDAFS, & A( LPOS ), LDAFS, ONE, A( APOS ), LDAFS ) END DO END IF END IF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_235 SUBROUTINE ZMUMPS_227 & ( IBEG_BLOCK, NASS, N, INODE, IW, LIW, & A, LA, LDAFS, & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,PIVSIZ, & XSIZE) IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER :: LIW COMPLEX(kind=8) A(LA) INTEGER IW(LIW) COMPLEX(kind=8) VALPIV INTEGER IOLDPS, NCB1 INTEGER LKJIT, IBEG_BLOCK INTEGER NPIV,JROW2 INTEGER(8) :: APOS INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NASS,N,INODE,IFINB,LKJIB,LDAFS, & NPBEG INTEGER NEL2 INTEGER XSIZE COMPLEX(kind=8) ONE, ALPHA COMPLEX(kind=8) ZERO INTEGER PIVSIZ,NPIV_NEW INTEGER(8) :: IBEG, IEND, IROW INTEGER :: J2 COMPLEX(kind=8) SWOP,DETPIV,MULT1,MULT2 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 = IW(IOLDPS+1+XSIZE) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) ENDIF JROW2 = IW(IOLDPS+3+XSIZE) NPBEG = IBEG_BLOCK NEL2 = JROW2 - NPIV_NEW IF (NEL2.EQ.0) THEN IF (JROW2.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) A(APOS) = VALPIV LPOS = APOS + LDAFS8 CALL zcopy(NASS-NPIV_NEW, A(LPOS), LDAFS, A(APOS+1_8), 1) CALL ZMUMPS_XSYR('U', NEL2, -VALPIV, A(LPOS), LDAFS, & A(LPOS+1_8), LDAFS) CALL zscal(NASS-NPIV_NEW, VALPIV, A(LPOS), LDAFS) IF (NEL2.GT.0) THEN K1POS = LPOS + int(NEL2,8)*LDAFS8 NCB1 = NASS - JROW2 CALL zgeru(NEL2, NCB1 , ALPHA, A(APOS+1_8), 1, & A(K1POS), LDAFS, A(K1POS+1_8), LDAFS) 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) A(POSPV2) = A(POSPV1)/DETPIV A(POSPV1) = SWOP/DETPIV A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV 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 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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 = JROW2+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A(POSPV1)*A(K1)+A(POSPV1+1_8)*A(K2)) MULT2 = - (A(POSPV1+1_8)*A(K1)+A(POSPV2)*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 ENDIF RETURN END SUBROUTINE ZMUMPS_227 RECURSIVE SUBROUTINE ZMUMPS_263( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER 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) ) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER MUMPS_275 EXTERNAL MUMPS_275 INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok 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 ) LAELL = int(NPIV,8) * int(NCOLU,8) IF ( LRLU .LT. LAELL ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_731(LAELL - LRLUS, IERROR) GOTO 700 END IF CALL ZMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731(LAELL - LRLU, IERROR) GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLU) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) 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 (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_731(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) ENDIF DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), & SLAVEF ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDDO DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IOLDPS = PTRIST(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAVES_TOT = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAVES_TOT + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 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 FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL ZMUMPS_190(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IW( IOLDPS + 6 + KEEP(IXSZ) ) = IW( IOLDPS + 6+ KEEP(IXSZ) ) + 1 IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 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_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL ZMUMPS_62( INODE, DEST, END_NIV2_LDLT, & COMM, 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 CALL ZMUMPS_759( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE ZMUMPS_263 SUBROUTINE ZMUMPS_38( 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_38 RECURSIVE SUBROUTINE ZMUMPS_80 & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, & NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & SHIFT_VAL_SON, LDA, 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE ZMUMPS_OOC USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) 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, LDA INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL INVERT 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 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) 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 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 BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 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_80' CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 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. INVERT ) 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.INVERT).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. INVERT ) 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. INVERT ) 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. INVERT ) 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 NBPROCFILS( STEP(IROOT) ) = -1 CALL ZMUMPS_284(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, IERROR ) IF (IFLAG.LT.0) THEN CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF ELSE NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT)) - 1 IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_681(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL ZMUMPS_580(IERR) ENDIF CALL ZMUMPS_507(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_500( & 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_285( 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), INVERT, & 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_285( 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), INVERT, & 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,': Error in b&scbroot: pb compress' WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL ZMUMPS_648( 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, INVERT, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 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_80" CALL ZMUMPS_44( MYID, SLAVEF, COMM ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING ZMUMPS_80" IFLAG = -20 IERROR = SIZE_MSG CALL ZMUMPS_44( MYID, SLAVEF, COMM ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN END SUBROUTINE ZMUMPS_80 SUBROUTINE ZMUMPS_285( 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, INVERT, & 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 INVERT 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. INVERT ) 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_285 SUBROUTINE ZMUMPS_164 &( 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_99( 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 CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. 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_164 SUBROUTINE ZMUMPS_165( 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 RETURN END SUBROUTINE ZMUMPS_165 SUBROUTINE ZMUMPS_99( 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_99 SUBROUTINE ZMUMPS_290(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 INTEGER STATUS(MPI_STATUS_SIZE) COMPLEX(kind=8) WK( MBLOCK * NBLOCK ) LOGICAL JUPDATE 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 RETURN END SUBROUTINE ZMUMPS_290 SUBROUTINE ZMUMPS_156(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 INTEGER STATUS(MPI_STATUS_SIZE) COMPLEX(kind=8) WK( MBLOCK * NBLOCK ) LOGICAL JUPDATE 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 RETURN END SUBROUTINE ZMUMPS_156 SUBROUTINE ZMUMPS_284(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, IERROR ) IMPLICIT NONE INCLUDE 'zmumps_root.h' INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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 ), PTRAIW(N), PTRARW( N ) INTEGER INTARR(max(1,KEEP(14))) COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) 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_760 ( 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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_284 SUBROUTINE ZMUMPS_760 & ( 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_760 INTEGER FUNCTION ZMUMPS_IXAMAX(n,x,incx) COMPLEX(kind=8) x(*) DOUBLE PRECISION smax integer i,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)go to 20 ix = 1 smax = abs(x(1)) ix = ix + incx do 10 i = 2,n if(abs(x(ix)).le.smax) go to 5 ZMUMPS_IXAMAX = i smax = abs(x(ix)) 5 ix = ix + incx 10 continue return 20 smax = abs(x(1)) do 30 i = 2,n if(abs(x(i)).le.smax) go to 30 ZMUMPS_IXAMAX = i smax = abs(x(i)) 30 continue return END FUNCTION ZMUMPS_IXAMAX SUBROUTINE ZMUMPS_XSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) CHARACTER UPLO INTEGER INCX, LDA, N COMPLEX(kind=8) ALPHA COMPLEX(kind=8) A( LDA, * ), X( * ) COMPLEX(kind=8) ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) INTEGER I, INFO, IX, J, JX, KX COMPLEX(kind=8) TEMP INTRINSIC max INFO = 0 IF( UPLO.NE.'U' .AND. UPLO.NE.'L' ) THEN INFO = 1 ELSE IF( N.LT.0 ) THEN INFO = 2 ELSE IF( INCX.EQ.0 ) THEN INFO = 5 ELSE IF( LDA.LT.max( 1, N ) ) THEN INFO = 7 END IF IF( INFO.NE.0 ) THEN WRITE(*,*) "Internal error in ZMUMPS_XSYR" CALL MUMPS_ABORT() RETURN END IF IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) ) & RETURN IF( INCX.LE.0 ) THEN KX = 1 - ( N-1 )*INCX ELSE IF( INCX.NE.1 ) THEN KX = 1 END IF IF( UPLO.EQ.'U' ) THEN IF( INCX.EQ.1 ) THEN DO 20 J = 1, N IF( X( J ).NE.ZERO ) THEN TEMP = ALPHA*X( J ) DO 10 I = 1, J A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX DO 40 J = 1, N IF( X( JX ).NE.ZERO ) THEN TEMP = ALPHA*X( JX ) IX = KX DO 30 I = 1, J A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 ) THEN DO 60 J = 1, N IF( X( J ).NE.ZERO ) THEN TEMP = ALPHA*X( J ) DO 50 I = J, N A( I, J ) = A( I, J ) + X( I )*TEMP 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80 J = 1, N IF( X( JX ).NE.ZERO ) THEN TEMP = ALPHA*X( JX ) IX = JX DO 70 I = J, N A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF RETURN END SUBROUTINE ZMUMPS_XSYR mumps-4.10.0.dfsg/src/dmumps_part5.F0000644000175300017530000102437711562233066017441 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE DMUMPS_26(id) USE DMUMPS_LOAD USE MUMPS_STATIC_MAPPING USE DMUMPS_STRUC_DEF USE TOOLS_COMMON USE DMUMPS_PARALLEL_ANALYSIS IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) TYPE(DMUMPS_STRUC), TARGET :: id INTEGER LIW, IKEEP, FILS, FRERE, PTRAR, NFSIZ INTEGER NE, NA INTEGER I, allocok INTEGER MAXIS1_CHECK 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 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 INTEGER(8) K13TMP8, K14TMP8 DOUBLE PRECISION PEAK INTEGER, ALLOCATABLE, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR 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_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 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 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 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 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (PROK) WRITE( MP, 220 ) IF (PROKG.AND.(MPG .NE. MP)) WRITE( MPG, 220 ) id%VERSION_NUMBER 220 FORMAT( /' DMUMPS ',A ) 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 ) CALL DMUMPS_647(id) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ) ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN CALL MPI_ALLREDUCE( id%NZ_loc, id%NZ, 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR ) ELSE CALL MPI_BCAST( id%NZ, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) END IF ELSE CALL MPI_BCAST( id%NA_ELT, 1, MPI_INTEGER, 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_427( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO) CALL DMUMPS_658(id) IF (KEEP(244) .EQ. 1) THEN IF ( KEEP(54) .eq. 3 ) THEN CALL DMUMPS_664(id) END IF IF ( id%MYID .eq. MASTER ) THEN 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 IF (.not.associated(id%A)) THEN IF (KEEP(23).GT.2) KEEP(23) = 1 ENDIF CALL DMUMPS_203(id%N, id%NZ, KEEP(23), id%IS1(1), id, & ICNTL(1), INFO(1)) IF (INFO(1) .LT. 0) THEN KEEP(23) = 0 GOTO 10 END IF END IF IF (KEEP(55) .EQ. 0) THEN IF ( KEEP(256) .EQ. 1 ) THEN LIW = 2 * id%NZ + 3 * id%N + 2 ELSE LIW = 2 * id%NZ + 3 * id%N + 2 ENDIF IF (LIW.LT.3*id%N) LIW = 3*id%N ELSE #if defined(metis) || defined(parmetis) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN LIW = id%N + id%N + 1 ELSE LIW = id%N + id%N + id%N+3 + id%N+1 ENDIF ENDIF IF (LIW.LT.3*id%N) LIW = 3*id%N 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 PTRAR = FRERE + id%N IF (KEEP(55) .EQ. 0) THEN NFSIZ = PTRAR + 4 * id%N MAXIS1_CHECK = NFSIZ + id%N - 1 ELSE NFSIZ = PTRAR + 2 * (NELT + 1) MAXIS1_CHECK = NFSIZ + id%N -1 ENDIF IF ( id%MAXIS1 .LT. MAXIS1_CHECK ) THEN IF (LP.GE.0) THEN WRITE(LP,*) '***********************************' WRITE(LP,*) 'MAXIS1 and MAXIS1_CHECK are different !!' WRITE(LP,*) 'MAXIS1, MAXIS1_CHECK=',id%MAXIS1, & MAXIS1_CHECK WRITE(LP,*) 'This might cause problems ...' WRITE(LP,*) '***********************************' ENDIF END IF IF ( KEEP(256) .EQ. 1 ) THEN DO I = 1, id%N id%IS1( IKEEP + I - 1 ) = id%PERM_IN( I ) END DO END IF INFOG(1) = 0 INFOG(2) = 0 INFOG(8) = -1 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 IF (KEEP(55) .EQ. 0) THEN CALL DMUMPS_195(id%N, id%NZ, id%IRN(1), id%JCN(1), & LIW, id%IS1(IKEEP), & id%IS1(PTRAR), 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 KEEP(23) = -KEEP(23) IF (.NOT. associated(id%A)) KEEP(23) = 1 GOTO 1234 ENDIF INFOG(7) = KEEP(256) ELSE allocate( IWtemp ( 3*id%N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*id%N IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IWtemp' END IF GOTO 10 ENDIF allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL DMUMPS_128(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW, & id%IS1(IKEEP), & IWtemp(1), 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%ELTPROC(1), id%NSLAVES, & XNODEL(1), NODEL(1)) DEALLOCATE(IWtemp) INFOG(7)=KEEP(256) ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN deallocate( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) ENDIF INFO(1)=INFOG(1) INFO(2)=INFOG(2) KEEP(28) = INFOG(6) IF ( INFO(1) .LT. 0 ) THEN GO TO 10 ENDIF ENDIF ELSE IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N PTRAR = FRERE + id%N NFSIZ = PTRAR + 4 * id%N IF(id%MYID .EQ. MASTER) THEN WORK1PTR => id%IS1(IKEEP : IKEEP + 3*id%N-1) WORK2PTR => id%IS1(PTRAR : PTRAR + 4*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) ELSE ALLOCATE(WORK1PTR(3*id%N)) ALLOCATE(WORK2PTR(4*id%N)) END IF CALL DMUMPS_715(id, & WORK1PTR, & WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR) IF(id%MYID .EQ. 0) THEN NULLIFY(WORK1PTR, WORK2PTR, NFSIZPTR) NULLIFY(FILSPTR, FREREPTR) ELSE DEALLOCATE(WORK1PTR, WORK2PTR) END IF KEEP(28) = INFOG(6) END IF 10 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN IF(id%MYID .EQ. MASTER) THEN CALL MUMPS_633(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL DMUMPS_348(id%N, id%IS1(FILS), id%IS1(FRERE), & id%IS1(IKEEP+2*id%N), id%IS1(IKEEP+id%N)) IF (id%NSLAVES .EQ. 1) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN id%KEEP(20)=0 id%KEEP(38)=0 ENDIF id%KEEP(56)=0 id%PROCNODE = 0 IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN CALL DMUMPS_564(id%KEEP(38), id%PROCNODE(1), & 1+2*id%NSLAVES, id%IS1(FILS),id%N) ENDIF ELSE PEAK = dble(id%INFOG(5))*dble(id%INFOG(5)) + & dble(id%KEEP(2))*dble(id%KEEP(2)) SSARBR => id%IS1(IKEEP:IKEEP+id%N-1) CALL DMUMPS_537(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 in MUMPS_369' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL DMUMPS_348(id%N, id%IS1(FILS), & id%IS1(FRERE), id%IS1(IKEEP+2*id%N), & id%IS1(IKEEP+id%N)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ) ELSE LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_733(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_733(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_733(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN IF(id%MYID .EQ. MASTER) THEN CALL DMUMPS_153( & 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 id%PTRAR(id%NELT+I+1)=id%ELTPTR(I) ENDDO deallocate(XNODEL) deallocate(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER, & 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 IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN CALL DMUMPS_120(id%N, NELT, id%ELTPROC(1),id%NSLAVES, & id%PROCNODE(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LP .GT. 0 ) 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_330(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_26", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_393 & (PAR2_NODES,id%CANDIDATES,IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF CALL MUMPS_494() 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF 12 CONTINUE KEEP(84) = ICNTL(27) END IF CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MUMPS_749( id%KEEP8(21), MASTER, & id%MYID, id%COMM, IERR) CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MUMPS_733(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_733(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_733(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_733(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_733(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_733(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_733(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_733(id%SYM_PERM, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 IF (KEEP(55) .EQ. 0) THEN LPTRAR = id%N+id%N CALL MUMPS_733(id%PTRAR, LPTRAR, id%INFO, LP, FORCE=.TRUE., & STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF ( associated( id%UNS_PERM ) ) deallocate(id%UNS_PERM) IF ( id%MYID == MASTER .AND. id%KEEP(23) .NE. 0 ) THEN allocate(id%UNS_PERM(id%N),stat=allocok) IF ( allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = id%N IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'id%UNS_PERM' END IF GOTO 94 ENDIF DO I=1,id%N id%UNS_PERM(I) = id%IS1(I) END DO ENDIF 94 CONTINUE CALL MUMPS_276( 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 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_733(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 id%NA(1) = NBLEAF id%NA(2) = NBROOT 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF IF ( id%MYID .EQ. MASTER ) THEN ISTEP = 0 DO I = 1, id%N IF ( id%IS1(FRERE+I-1) .ne. id%N + 1 ) THEN 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 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_26' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in DMUMPS_26' CALL MUMPS_ABORT() ENDIF 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 DO I = 1, id%N IF ( id%STEP(I) .LE. 0) CYCLE IF (id%IS1(FRERE+I-1) .eq. 0) THEN id%DAD_STEPS(id%STEP(I)) = 0 ENDIF IFS = id%IS1(FILS+I-1) DO WHILE ( IFS .GT. 0 ) IFS= id%IS1(FILS + IFS -1) END DO IFS = -IFS DO WHILE (IFS.GT.0) id%DAD_STEPS(id%STEP(IFS)) = I IFS = id%IS1(FRERE+IFS-1) ENDDO END DO deallocate(id%PROCNODE) NULLIFY(id%PROCNODE) deallocate(id%IS1) NULLIFY(id%IS1) CALL DMUMPS_363(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(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 SIZE_TEMP_MEM = id%NBSA ELSE 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 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 ( LP .GT. 0 ) 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_364(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 CALL DMUMPS_181(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) ) ENDIF 80 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN 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(55) .EQ. 0) THEN CALL DMUMPS_746(id, id%PTRAR(1)) IF(id%MYID .EQ. MASTER) THEN IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN DEALLOCATE( id%IRN ) DEALLOCATE( id%JCN ) END IF END IF ENDIF 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_276( 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 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 ( LP .GT. 0 ) 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 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(id%STEP(INN)) = INIV2 END DO CALL DMUMPS_649( id%NSLAVES, & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF #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 ( LP .GT. 0 ) 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_275( & id%PROCNODE_STEPS(id%STEP(PAR2_NODES(INIV2))), & id%NSLAVES) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO #endif 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 allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LP .GT. 0 ) 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 IF (NB_NIV2.GT.0) deallocate (PAR2_NODES) 321 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN 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 PTRAR = FRERE + id%N IF (KEEP(55) .EQ. 0) THEN IF ( id%MYID.EQ.MASTER ) THEN NFSIZ = PTRAR + 4 * id%N ELSE NFSIZ = PTRAR + 2 * id%N ENDIF ELSE NFSIZ = PTRAR + 2 * (NELT + 1) END IF IF ( KEEP(38) .NE. 0 ) THEN CALL DMUMPS_164( 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 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 ( LP > 0 .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 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF ( I_AM_SLAVE ) THEN IF (KEEP(55) .EQ. 0) THEN CALL DMUMPS_24( 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_25( 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 IF ( I_AM_SLAVE ) THEN 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 id%SCHUR_MLOC=LOCAL_M id%SCHUR_NLOC=LOCAL_N 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_246( id%MYID_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), & KEEP8(14), & 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), & id%I_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%MAX_SURF_MASTER = KEEP8(15) KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 2* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) INFO( 19 ) = KEEP(225) + 2* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /100_8 +1_8) CALL MUMPS_736 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) 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 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 ) KEEP(44) = max(KEEP(44), MIN_BUF_SIZE) KEEP(43) = max(KEEP(43), MIN_BUF_SIZE) IF ( MP .GT. 0 ) THEN WRITE(MP,'(A,I10) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I10) ') & ' INFO(3), est. real space to store factors :', & KEEP8(11) WRITE(MP,'(A,I10) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I10) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I10) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I10) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I10) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF ELSE 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 CALL MUMPS_736( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_736( 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_646( KEEP8(11), KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735( KEEP8(111), INFOG(3) ) CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_DOUBLE_PRECISION, MPI_SUM, & id%COMM, IERR) CALL MUMPS_735( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_735( KEEP8(13), INFO(8) ) CALL MUMPS_735( KEEP8(17), INFO(20) ) CALL MUMPS_735( KEEP8(9), INFO(24) ) INFOG( 4 ) = KEEP( 126 ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_735( KEEP8(109), INFOG(20) ) CALL DMUMPS_100(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1)) OOC_STAT = KEEP(201) IF (KEEP(201) .NE. -1) OOC_STAT=0 PERLU_ON = .FALSE. CALL DMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(2) = TOTAL_BYTES PERLU_ON = .TRUE. CALL DMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' Estimated space in MBYTES for IC factorization :', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES CALL MUMPS_243( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of proc needing largest memory in IC facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Estimated corresponding MBYTES for IC facto :', & id%INFOG(16) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,(id%INFOG(17)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,id%INFOG(17)/id%NSLAVES END IF WRITE(MPG,'(A,I10) ') & ' ** TOTAL space in MBYTES for IC factorization :' & ,id%INFOG(17) END IF 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. CALL DMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(3) = TOTAL_BYTES PERLU_ON = .TRUE. CALL DMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) id%INFO(17) = TOTAL_MBYTES CALL MUMPS_243( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of proc needing largest memory for OOC facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Estimated corresponding MBYTES for OOC facto :', & id%INFOG(26) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,(id%INFOG(27)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,id%INFOG(27)/id%NSLAVES END IF WRITE(MPG,'(A,I10) ') & ' ** TOTAL space in MBYTES for OOC factorization :' & ,id%INFOG(27) END IF IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) & deallocate( id%MAPPING) allocate( id%MAPPING(id%NZ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NZ IF ( LP .GT. 0 ) 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF CALL DMUMPS_83( & id%N, id%MAPPING(1), & id%NZ, 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 150 FORMAT( & /' ** FAILURE DURING DMUMPS_26, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE DMUMPS_26 SUBROUTINE DMUMPS_537(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_369(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & ) RETURN END SUBROUTINE DMUMPS_537 SUBROUTINE DMUMPS_564(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_564 SUBROUTINE DMUMPS_647(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (id%MYID.eq.MASTER) THEN id%KEEP(256) = id%ICNTL(7) id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 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 id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN 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 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 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 WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' id%KEEP(60)=0 END IF 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 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 IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF id%KEEP(244) = id%ICNTL(28) id%KEEP(245) = id%ICNTL(29) #if ! defined(parmetis) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP,'("ParMETIS not available.")') WRITE(LP,'("Aborting.")') RETURN END IF END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP,'("PT-SCOTCH not available.")') WRITE(LP,'("Aborting.")') RETURN END IF END IF #endif IF((id%KEEP(244) .GT. 2) .OR. & (id%KEEP(244) .LT. 0)) id%KEEP(244)=0 IF(id%KEEP(244) .EQ. 0) THEN id%KEEP(244) = 1 ELSE IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') RETURN END IF 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 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) = 0 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 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 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 IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF 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 id%INFO(1) = -22 id%INFO(2) = 8 RETURN IF (MPG.GT.0) 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 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 id%KEEP(23) = id%ICNTL(6) IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 7 IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not compatible with LLT factorization' END IF ENDIF id%KEEP(95) = 1 END IF IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (MPG.GT.0) 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 (MPG.GT.0) 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. MPG.GT.0) 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 (MPG.GT.0) 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 IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed for element matrix' END IF id%KEEP(23) = 0 ENDIF IF (MPG.GT.0 .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 IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') RETURN END IF END IF IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF IF (id%ICNTL(39).NE.1 .and. id%ICNTL(39).NE.2) THEN id%KEEP(106)=1 ELSE id%KEEP(106)=id%ICNTL(39) ENDIF IF(id%KEEP(50) .EQ. 2) THEN IF( .NOT. associated(id%A) ) THEN 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 IF (PROK) WRITE(MP,*) & 'WARNING: DMUMPS_203 constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) 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 IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE 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 id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF id%KEEP(53)=0 IF(id%KEEP(86).EQ.1)THEN 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 END IF RETURN END SUBROUTINE DMUMPS_647 SUBROUTINE DMUMPS_664(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE(DMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER :: MASTER, IERR, INDX, NRECV INTEGER :: STATUS( MPI_STATUS_SIZE ) INTEGER :: LP, MP, MPG, I LOGICAL :: PROK, PROKG PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN id%NZ_loc = 0 END IF IF ( id%MYID .eq. MASTER ) THEN allocate( REQPTR( id%NPROCS, 3 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 3 * id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'REQPTR' END IF GOTO 13 END IF allocate( id%IRN( id%NZ ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NZ IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IRN' END IF GOTO 13 END IF allocate( id%JCN( id%NZ ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NZ IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'JCN' END IF GOTO 13 END IF END IF 13 CONTINUE CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN IF ( id%MYID .EQ. MASTER ) THEN DO I = 1, id%NPROCS - 1 CALL MPI_RECV( REQPTR( I+1, 1 ), 1, & MPI_INTEGER, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) END DO IF ( id%KEEP(46) .eq. 0 ) THEN REQPTR( 1, 1 ) = 1 ELSE REQPTR( 1, 1 ) = id%NZ_loc + 1 END IF DO I = 2, id%NPROCS REQPTR( I, 1 ) = REQPTR( I, 1 ) + REQPTR( I-1, 1 ) END DO ELSE CALL MPI_SEND( id%NZ_loc, 1, MPI_INTEGER, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN NRECV = 0 DO I = 1, id%NPROCS - 1 IF ( REQPTR( I + 1, 1 ) - REQPTR( I, 1 ) .NE. 0 ) THEN NRECV = NRECV + 2 CALL MPI_IRECV( id%IRN( REQPTR( I, 1 ) ), & REQPTR( I + 1, 1 ) - REQPTR( I, 1 ), & MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I, 2), IERR ) CALL MPI_IRECV( id%JCN( REQPTR( I, 1 ) ), & REQPTR( I + 1, 1 ) - REQPTR( I, 1 ), & MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I, 3), IERR ) ELSE REQPTR(I, 2) = MPI_REQUEST_NULL REQPTR(I, 3) = MPI_REQUEST_NULL END IF END DO ELSE IF ( id%NZ_loc .NE. 0 ) THEN CALL MPI_SEND( id%IRN_loc(1), id%NZ_loc, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(1), id%NZ_loc, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END IF END IF IF ( id%MYID .eq. MASTER ) THEN IF ( id%NZ_loc .NE. 0 ) THEN DO I=1,id%NZ_loc id%IRN(I) = id%IRN_loc(I) id%JCN(I) = id%JCN_loc(I) ENDDO END IF REQPTR( id%NPROCS, 2 ) = MPI_REQUEST_NULL REQPTR( id%NPROCS, 3 ) = MPI_REQUEST_NULL DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * id%NPROCS, REQPTR( 1, 2 ), INDX, STATUS, IERR ) END DO deallocate( REQPTR ) END IF RETURN 150 FORMAT( &/' ** FAILURE DURING DMUMPS_664, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE DMUMPS_664 SUBROUTINE DMUMPS_658(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(DMUMPS_STRUC) :: id 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) IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (id%MYID.EQ.MASTER .AND. .NOT. IS_DISTRIBUTED) THEN IF (id%WRITE_PROBLEM(1:20) .NE. "NAME_NOT_INITIALIZED")THEN OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL DMUMPS_166( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL ) CLOSE(IUNIT) ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN 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) IF (MM_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(MM_IDSTR,'(I7)') id%MYID_NODES OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(MM_IDSTR))) CALL DMUMPS_166(id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL ) CLOSE(IUNIT) ENDIF ENDIF 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_179(IUNIT, id) CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE DMUMPS_658 SUBROUTINE DMUMPS_166 & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL ) USE DMUMPS_STRUC_DEF IMPLICIT NONE LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL INTEGER, intent(in) :: IUNIT TYPE(DMUMPS_STRUC), intent(in) :: id CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER :: I IF (IS_ELEMENTAL) THEN RETURN ENDIF IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED) THEN IF (associated(id%A)) 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, id%NZ IF (associated(id%A)) THEN DO I=1,id%NZ IF (id%KEEP(50).NE.0 .AND. id%IRN(I).LT.id%JCN(I)) THEN WRITE(IUNIT,*) id%JCN(I), id%IRN(I), id%A(I) ELSE WRITE(IUNIT,*) id%IRN(I), id%JCN(I), id%A(I) ENDIF ENDDO ELSE DO I=1,id%NZ IF (id%KEEP(50).NE.0 .AND. id%IRN(I).LT.id%JCN(I)) THEN WRITE(IUNIT,*) id%JCN(I), id%IRN(I) ELSE WRITE(IUNIT,*) id%IRN(I), id%JCN(I) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN 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, id%NZ_loc IF (associated(id%A_loc)) THEN DO I=1,id%NZ_loc IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I), & id%A_loc(I) ELSE WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I), & id%A_loc(I) ENDIF ENDDO ELSE DO I=1,id%NZ_loc IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I) ELSE WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_166 SUBROUTINE DMUMPS_179(IUNIT, id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT CHARACTER (LEN=8) :: ARITH INTEGER :: I, J, K, LD_RHS 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_179 SUBROUTINE DMUMPS_649( NSLAVES, NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND 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 RETURN END SUBROUTINE DMUMPS_649 SUBROUTINE DMUMPS_251(N,IW,LIW,A,LA, & NSTK_STEPS, NBPROCFILS,IFLAG,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, IERROR,IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, & LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST_S, 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) USE DMUMPS_LOAD USE DMUMPS_OOC IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER N,IFLAG,NTOTPV,MAXFRT,LIW, LPTRAR, NMAXNPIV, & IERROR, 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 PTRARW(LPTRAR), PTRAIW(LPTRAR), ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST_S(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 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 ) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) LOGICAL IS_ISOLATED_NODE INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBRTOT, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS 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_330, MUMPS_275 INTEGER MUMPS_330, MUMPS_275 LOGICAL MUMPS_167,MUMPS_283 EXTERNAL MUMPS_167,MUMPS_283 LOGICAL DMUMPS_508 EXTERNAL DMUMPS_508, DMUMPS_509 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 ASS_IRECV = MPI_REQUEST_NULL ITLOC(1:N+KEEP(253)) =0 PTRIST (1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRAST(1:KEEP(28))=0_8 PTRFAC(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_22( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, & IFLAG, IERROR & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 NBPROCFILS(1:KEEP(28)) = 0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL DMUMPS_284( & 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, IFLAG, KEEP,KEEP8, IERROR ) ENDIF IF ( IFLAG .LT. 0 ) GOTO 635 END IF 20 CONTINUE NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( & 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_STEPS, & COMP, IFLAG, & IERROR, COMM_NODES, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED ) CALL DMUMPS_467(COMM_LOAD, KEEP) IF (MESSAGE_RECEIVED) THEN IF ( IFLAG .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. DMUMPS_508( IPOOL, LPOOL) )THEN CALL DMUMPS_509( 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_500( & 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_501( & 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_512(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_242(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_330(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_144( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, & NPVW, & COMM_NODES, MYID_NODES, 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_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) IF ( IFLAG .LT. 0 ) GOTO 640 ELSE CALL DMUMPS_141( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, & NPVW, & COMM_NODES, MYID_NODES, 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_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) IF ( IFLAG .LT. 0 ) GOTO 640 IF ( IW( PTLUST_S(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_176( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & IFLAG, IERROR, COMM_NODES, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL DMUMPS_36( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ELSE JOBASS = 0 CALL DMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF IF ( IFLAG .LT. 0 ) GOTO 640 IF ((NBPROCFILS(STEP(INODE)).GT.0).OR.(SON_LEVEL2)) GOTO 20 ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL DMUMPS_253(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & IFLAG, IERROR, & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & ) ELSE CALL DMUMPS_37( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, IFLAG, IERROR, & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0)) END IF IF (IFLAG.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_251", POSELT CALL MUMPS_ABORT() ENDIF CALL DMUMPS_87 & ( IW(PTLUST_S(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST_S(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_143( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & IFLAG, UU, NOFFW, NPVW, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL DMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL DMUMPS_140( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & IFLAG, UU, NOFFW, NPVW, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL DMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_330(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) ELSE TYPEF = -9999 END IF CALL DMUMPS_254( 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,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 ) IF (IFLAG.LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in DMUMPS_251: ', & ' 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_681(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL DMUMPS_580(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in DMUMPS_251: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in DMUMPS_251: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL DMUMPS_242( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_275(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_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF)) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL DMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE CALL DMUMPS_44( MYID_NODES, SLAVEF, COMM_NODES ) 640 CONTINUE CALL DMUMPS_255( INFO(1), & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL DMUMPS_180( INFO(1), & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, MP) 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_275( & 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_S(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_731(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before DMUMPS_146', LBUFRX CALL MUMPS_ABORT() ENDIF IS_BUFRX_ALLOCATED = .FALSE. ENDIF CALL DMUMPS_146( MYID_NODES, & root, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST_S, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_275(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_729(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 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL DMUMPS_688 & ( 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_576(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in DMUMPS_576' CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 IF (KEEP(252).NE.0) THEN CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLU) ELSE CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLU) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLU) 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_731(LRHS_CNTR_MASTER_ROOT,INFO(2)) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before DMUMPS_146', & 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_156( 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_S(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 CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-NFRONT8*NFRONT8,KEEP,KEEP8,LRLU) ENDIF ENDIF END IF END IF END IF IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_275(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_251 SUBROUTINE DMUMPS_87( 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' CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE DMUMPS_87 SUBROUTINE DMUMPS_136( id ) USE DMUMPS_OOC USE DMUMPS_STRUC_DEF USE DMUMPS_COMM_BUFFER IMPLICIT NONE include 'mpif.h' TYPE( DMUMPS_STRUC ) :: id LOGICAL I_AM_SLAVE INTEGER IERR, MASTER PARAMETER ( MASTER = 0 ) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL DMUMPS_587(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_276(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 CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF NULLIFY(id%SCHUR_CINTERFACE) 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%POIDS)) THEN DEALLOCATE(id%POIDS) NULLIFY(id%POIDS) ENDIF 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 IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF 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) ENDIF IF (associated(id%POSINRHSCOMP)) THEN DEALLOCATE(id%POSINRHSCOMP) NULLIFY(id%POSINRHSCOMP) ENDIF 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 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_636(id) IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF 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 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%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%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 IF (id%KEEP8(24).EQ.0_8) THEN IF (associated(id%S)) DEALLOCATE(id%S) ELSE ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN CALL DMUMPS_57( IERR ) CALL DMUMPS_59( IERR ) END IF IF ( associated( id%BUFR ) ) DEALLOCATE( id%BUFR ) NULLIFY( id%BUFR ) RETURN END SUBROUTINE DMUMPS_136 SUBROUTINE DMUMPS_150(MYID,COMM,S,MAXS,MAXS_BYTES) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) INTEGER COMM, MYID, MAXS, MAXS_BYTES INTEGER S( MAXS ) INTEGER MSGTAG, MSGSOU, MSGLEN LOGICAL FLAG FLAG = .TRUE. DO WHILE ( FLAG ) CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) IF (FLAG) THEN MSGTAG=STATUS(MPI_TAG) MSGSOU=STATUS(MPI_SOURCE) CALL MPI_GET_COUNT(STATUS,MPI_PACKED,MSGLEN,IERR) IF (MSGLEN <= MAXS_BYTES) THEN CALL MPI_RECV(S(1),MAXS_BYTES,MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR) ELSE EXIT ENDIF END IF END DO CALL MPI_BARRIER( COMM, IERR ) RETURN END SUBROUTINE DMUMPS_150 SUBROUTINE DMUMPS_254(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, & 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 ) USE DMUMPS_COMM_BUFFER 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) 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) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(max(1,KEEP(13))) INTEGER INTARR(max(1,KEEP(14))) 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 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_275 EXTERNAL MUMPS_275 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_167, &MUMPS_170 EXTERNAL MUMPS_167, MUMPS_170 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_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SSARBR_ROOT = MUMPS_170 & (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(*,*) "Error 1 in G" 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_511( 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_190(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_511( 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_190(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_511(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (SSARBR_ROOT) THEN CALL DMUMPS_190(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL DMUMPS_190(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_80( & 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, .FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_275(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_273( 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, & COMM, COMM_LOAD, FILS, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL DMUMPS_76( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE.) 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_275(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_275( 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_66( 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, IERR ) ELSE IF ( (TYPE.EQ.2).AND.(KEEP(48).NE.0)) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL DMUMPS_70( 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_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_254", 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_254", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_275(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_22( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,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_275(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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_652( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, COMPRESSCB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL DMUMPS_705( 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_651( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED ) 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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_93(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1) CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE DMUMPS_254 SUBROUTINE DMUMPS_142( id) USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD USE DMUMPS_OOC USE DMUMPS_STRUC_DEF IMPLICIT NONE #ifndef SUN_ INTERFACE SUBROUTINE DMUMPS_27(id, ANORMINF, LSCAL) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id DOUBLE PRECISION, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL END SUBROUTINE DMUMPS_27 END INTERFACE #endif TYPE(DMUMPS_STRUC), TARGET :: id INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INCLUDE 'mumps_headers.h' INTEGER NSEND, NSEND_TOT, LDPTRAR, NELT INTEGER NLOCAL, NLOCAL_TOT, KEEP13_SAVE, ITMP INTEGER(8) K67 INTEGER(8) ITMP8 INTEGER MUMPS_275 EXTERNAL MUMPS_275 INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL INTEGER DMUMPS_LBUF, DMUMPS_LBUFR_BYTES, DMUMPS_LBUF_INT INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, NSTEPS, K28, LPOOL, LIW INTEGER IRANK, ID_ROOT INTEGER KKKK, NZ_locMAX 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 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233 INTEGER COLOUR, COMM_FOR_SCALING INTEGER LIWK, LWK, LWK_REAL LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED 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, 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 INTEGER, POINTER :: JOB, NZ DOUBLE PRECISION,DIMENSION(:),POINTER::RINFO, RINFOG DOUBLE PRECISION,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER::INFO, 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(8),DIMENSION(:),POINTER::KEEP8 INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL DMUMPS_505 INTEGER DMUMPS_505 INTEGER(8) TOTAL_BYTES INTEGER(8) :: I8TMP INTEGER numroc EXTERNAL numroc DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED JOB=>id%JOB NZ=>id%NZ RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFO=>id%INFO INFOG=>id%INFOG KEEP=>id%KEEP KEEP8=>id%KEEP8 ICNTL=>id%ICNTL IF (id%NZ_loc .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 ) NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. IF (KEEP8(24).GT.0_8) THEN NULLIFY(id%S) ENDIF WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN KEEP8(24) = int(id%LWK_USER,8) ELSE KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE KEEP8(24) = 0_8 ENDIF KEEP13_SAVE = KEEP(13) id%DKEEP(4)=-1.0D0 id%DKEEP(5)=-1.0D0 MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LP = ICNTL( 1 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) 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. 0 ) 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 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN KEEP(201)=id%ICNTL(22) IF (KEEP(201) .NE. 0) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF 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(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 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 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 IF ( KEEP(50) .eq. 1 ) THEN IF (id%CNTL(1) .ne. ZERO ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') &' ** Warning : SPD solver called, resetting CNTL(1) to 0.0D0' END IF END IF id%CNTL(1) = ZERO END IF IF (KEEP(219).NE.0) THEN CALL DMUMPS_617(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN INFO(1) = -13 INFO(2) = max(KEEP(108),1) END IF ENDIF IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN 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 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: sparse RHS incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 IF ( PROKG ) THEN WRITE( MPG, 172 ) id%NSLAVES, id%ICNTL(22), & KEEP8(111), KEEP(126), KEEP(127), KEEP(28) IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) ENDIF IF (KEEP(201).LE.0) THEN KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF 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 KEEP(260) = 1 id%DKEEP(6) = 1.0D0 ENDIF 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 IF ( id%MYID.EQ.MASTER ) THEN ENDIF IF (KEEP(52) .EQ. 7) THEN K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN 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 INFO(1)=-13 INFO(2)=LIWK+M+N+4* (id%NPROCS) ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 BUJOB = 1 LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL)) CALL DMUMPS_693( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%NZ_loc, & 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 INFO(1)=-13 INFO(2)=LIWK ENDIF ENDIF LWK_REAL = BURESZ DEALLOCATE(WK_REAL) ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=LWK_REAL ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 BUJOB = 2 CALL DMUMPS_693( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%NZ_loc, & 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 DEALLOCATE(IWK, WK_REAL,BURP,BUCP,BURS, BUCS) ELSE IF ( KEEP(54) .EQ. 0 ) THEN IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN 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 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 INFO(1)=-13 INFO(2)=1 ENDIF IF (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_693( & id%IRN(1), id%JCN(1), id%A(1), & id%NZ, & 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 INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL DMUMPS_693(id%IRN(1), & id%JCN(1), id%A(1), & id%NZ, & 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 DEALLOCATE(WK_REAL) DEALLOCATE (IWK,BURP,BUCP, & BURS,BUCS) ENDIF CALL MPI_BCAST( id%DKEEP(4),2,MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) 400 CONTINUE IF (id%MYID.EQ.MASTER) THEN CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF (INFO(1).LT.0) GOTO 530 ELSE IF (id%MYID.EQ.MASTER) THEN IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN IF ( KEEP(52) .eq. 5 .or. & KEEP(52) .eq. 6 ) THEN LWK = NZ ELSE LWK = 1 END IF LWK_REAL = 5 * N ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK_REAL GOTO 137 END IF ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK GOTO 137 END IF CALL DMUMPS_217(N, NZ, 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), INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN 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 = (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_761(id%ROWSCA(I), & id%DKEEP(6), & KEEP(259)) ENDDO IF (KEEP(50) .EQ. 0) THEN DO I = 1, id%N CALL DMUMPS_761(id%COLSCA(I), & id%DKEEP(6), & KEEP(259)) ENDDO ELSE CALL DMUMPS_765(id%DKEEP(6), KEEP(259)) ENDIF CALL DMUMPS_766(id%DKEEP(6), KEEP(259)) ENDIF 137 CONTINUE 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 ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N id%KEEP(255) = N*id%KEEP(253) ALLOCATE(RHS_MUMPS(id%KEEP(255)),stat=IERR) IF (IERR > 0) THEN INFO(1)=-13 INFO(2)=id%KEEP(255) IF (LP > 0) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ELSE id%KEEP(254)=id%LRHS id%KEEP(255)=id%LRHS*(id%KEEP(253)-1)+id%N RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN 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 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 ELSE id%KEEP(255)=1 ALLOCATE(RHS_MUMPS(1)) RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).lt.0 ) GOTO 530 KEEP(110)=ICNTL(24) CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(110).NE.1) KEEP(110)=0 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) ANORMINF = ZERO IF (KEEP(19).EQ.0) THEN SEUIL = ZERO ELSE CALL DMUMPS_27( id , ANORMINF, LSCAL ) IF (CNTL6 .LT. ZERO) THEN SEUIL = EPS*ANORMINF ELSE SEUIL = CNTL6*ANORMINF ENDIF IF (PROKG) WRITE(MPG,*) & ' ABSOLUTE PIVOT THRESHOLD for rank revealing =',SEUIL ENDIF SEUIL_LDLT_NIV2 = SEUIL IF (KEEP(110).EQ.0) THEN id%DKEEP(1) = -1.0D0 id%DKEEP(2) = ZERO ELSE IF (ANORMINF.EQ.ZERO) & CALL DMUMPS_27( id , ANORMINF, LSCAL ) IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE id%DKEEP(1) = 1.0D-5*EPS*ANORMINF 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 id%DKEEP(2) = -max(1.0D10*ANORMINF, & sqrt(huge(ANORMINF))/1.0D8) ELSE id%DKEEP(2) = ZERO ENDIF ENDIF ENDIF IF (KEEP(53).NE.0) THEN ID_ROOT =MUMPS_275(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%NSLAVES) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF IF ( associated( id%PIVNUL_LIST) ) DEALLOCATE(id%PIVNUL_LIST) IF(KEEP(110) .EQ. 1) THEN LPN_LIST = N ELSE LPN_LIST = 1 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 INFO(1)=-13 INFO(2)=LPN_LIST END IF id%PIVNUL_LIST(1:LPN_LIST) = 0 KEEP(109) = 0 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).lt.0 ) GOTO 530 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN IF(ANORMINF .EQ. ZERO) THEN CALL DMUMPS_27( id , ANORMINF, LSCAL ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL ELSE SEUIL = ZERO ENDIF ENDIF KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 IF ( id%MYID.EQ.MASTER ) THEN ITMP = ICNTL(23) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (WK_USER_PROVIDED) ITMP = 0 ITMP8 = int(ITMP, 8) KEEP8(4) = ITMP8 * 1000000_8 PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8=KEEP8(12) ELSE MAXS_BASE8=KEEP8(14) ENDIF IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) ELSE IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) IF (MAXS_BASE_RELAXED8 > huge(MAXS)) THEN WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ENDIF MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) MAXS = MAXS_BASE_RELAXED8 ELSE MAXS = 1_8 MAXS_BASE_RELAXED8 = 1_8 END IF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) .LT. 0) THEN GOTO 530 ENDIF IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN IF (KEEP(96).GT.0) THEN MAXS=int(KEEP(96),8) ELSE IF (KEEP8(4) .NE. 0_8) THEN PERLU_ON = .TRUE. CALL DMUMPS_214( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., KEEP(201), & PERLU_ON, TOTAL_BYTES) MAXS_BASE_RELAXED8=MAXS_BASE_RELAXED8 + & (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 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,4) ELSE MAXS=MAXS_BASE_RELAXED8 ENDIF ENDIF ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) .LT. 0) THEN GOTO 530 ENDIF CALL DMUMPS_713(PROKG, MPG, MAXS, id%NSLAVES, & id%COMM, "effective relaxed size of S =") CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF IF ( I_AM_SLAVE ) THEN CALL DMUMPS_188( dble(id%COST_SUBTREES), & KEEP(64), KEEP(66),MAXS ) K28=KEEP(28) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), & max(0_8, MAXS-MAXS_BASE8)) CALL DMUMPS_185( id, MEMORY_MD_ARG, MAXS ) CALL DMUMPS_587(id, IERR) IF (IERR < 0) THEN INFO(1) = -90 INFO(2) = 0 GOTO 112 ENDIF IF (KEEP(201) .GT. 0) THEN IF (KEEP(201).EQ.1 & .AND.KEEP(50).EQ.0 & .AND.KEEP(251).NE.2 & ) THEN OOC_NB_FILE_TYPE=2 ELSE OOC_NB_FILE_TYPE=1 ENDIF IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN I8TMP = int(OOC_NB_FILE_TYPE,8) * 2_8 * int(KEEP(226),8) ELSE I8TMP = 2_8 * KEEP8(119) ENDIF I8TMP = I8TMP + int(max(KEEP(12),0),8) * & (I8TMP/100_8+1_8) I8TMP = min(I8TMP, 12000000_8) KEEP(100)=int(I8TMP) ENDIF IF (KEEP(201).EQ.1) THEN IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF IF (id%MYID_NODES .eq. MASTER) THEN write(6,*) ' PANEL: INIT and force STRAT_IO= ', & id%KEEP(99) ENDIF ENDIF 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), & OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) < 0) THEN 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_575(id,MAXS) ELSE WRITE(*,*) "Internal error in DMUMPS_142" CALL MUMPS_ABORT() ENDIF IF(INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF #if ! defined(OLD_LOAD_MECHANISM) CALL DMUMPS_190(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) #endif IF (INFO(1).LT.0) GOTO 111 #if defined(stephinfo) write(*,*) 'proc ',id%MYID,' array of dist : ', & id%MEM_DIST(0:id%NSLAVES - 1) #endif END IF IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN ALLOCATE (id%S(MAXS),stat=IERR) KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_735(MAXS, INFO(2)) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ELSE id%S => id%WK_USER(1:KEEP8(24)) ENDIF #if defined (LARGEMATRICES) END IF #endif 111 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP(55) .eq. 0 ) THEN IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE .and. KEEP(13) .ne. 0 ) THEN ALLOCATE( id%DBLARR( KEEP(13) ), stat = IERR ) ELSE ALLOCATE( id%DBLARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID, & ':Error allocating DBLARR : IERR = ', IERR INFO(1)=-13 INFO(2)=KEEP(13) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( I_AM_SLAVE .and. KEEP(14) .ne. 0 ) THEN ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = KEEP(14) 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 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 id%DBLARR => id%A_ELT ELSE IF ( KEEP(13) .ne. 0 ) THEN ALLOCATE( id%DBLARR( KEEP(13) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = KEEP(13) 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 IF ( KEEP(38).NE.0 .AND. I_AM_SLAVE ) THEN CALL DMUMPS_165( id%N, & id%root, id%FILS(1), KEEP(38), id%KEEP(1), id%INFO(1) ) END IF 100 CONTINUE CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP( 55 ) .eq. 0 ) THEN IF (KEEP(38).NE.0 .AND. I_AM_SLAVE) THEN LWK = numroc( id%root%ROOT_SIZE, id%root%MBLOCK, & id%root%MYROW, 0, id%root%NPROW ) LWK = max( 1, LWK ) LWK = LWK* & numroc( id%root%ROOT_SIZE, id%root%NBLOCK, & id%root%MYCOL, 0, id%root%NPCOL ) LWK = max( 1, LWK ) ELSE LWK = 1 ENDIF IF (MAXS .LT. int(LWK,8)) THEN INFO(1) = -9 INFO(2) = LWK ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN ALLOCATE(IWK(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN INFO(1)=-13 INFO(2)=id%N END IF #if defined(LARGEMATRICES) IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( .not. associated( id%INTARR ) ) THEN ALLOCATE( id%INTARR( 1 ) ) ENDIF #if defined(LARGEMATRICES) CALL DMUMPS_148(id%N, NZ, 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), & min(KEEP(39),id%NZ), & LP, id%COMM, id%root, KEEP,KEEP8, & id%FILS(1), IWK(1), & & id%INTARR(1), id%DBLARR(1), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), int(LWK,8), & id%ISTEP_TO_INIV2, id%I_AM_CAND, & id%CANDIDATES) write(6,*) '!!! A,IRN,JCN are freed during facto ' 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) KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = MAXS NULLIFY(id%S) KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ELSE id%S => id%WK_USER(1:KEEP8(24)) ENDIF id%S(MAXS-LWK+1:MAXS) = WK(1:LWK) DEALLOCATE (WK) #else CALL DMUMPS_148(id%N, NZ, 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), & min(KEEP(39),id%NZ), & LP, id%COMM, id%root, KEEP(1),KEEP8(1), & id%FILS(1), IWK(1), & & id%INTARR(1), id%DBLARR(1), & 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) IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF ELSE CALL DMUMPS_145( id%N, & id%DBLARR( 1 ), max(1,KEEP( 13 )), & id%INTARR( 1 ), max(1,KEEP( 14 )), & id%PTRAR( 1 ), & id%PTRAR(id%N+1), & KEEP( 1 ), KEEP8(1), id%MYID, id%COMM, & min(id%KEEP(39),id%NZ), & & 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 IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( I_AM_SLAVE ) THEN NZ_locMAX = 0 CALL MPI_ALLREDUCE(id%NZ_loc, NZ_locMAX, 1, MPI_INTEGER, & MPI_MAX, id%COMM_NODES, IERR) CALL DMUMPS_282( id%N, & id%NZ_loc, & id, & id%DBLARR(1), KEEP(13), id%INTARR(1), & KEEP(14), id%PTRAR(1), id%PTRAR(id%N+1), & KEEP(1), KEEP8(1), id%MYID_NODES, & id%COMM_NODES, min(id%KEEP(39),NZ_locMAX), & 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), NSEND, NLOCAL, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN 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) 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) NLOCAL, NSEND END IF END IF IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN NSEND = 0 NLOCAL = 0 END IF CALL MPI_REDUCE( NSEND, NSEND_TOT, 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL, NLOCAL_TOT, 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT, NSEND_TOT END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF END IF ELSE IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( id%MYID.eq.MASTER) &CALL DMUMPS_213( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) CALL DMUMPS_126( id%N, id%NELT, id%NA_ELT, & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & id%INTARR(1), id%DBLARR(1), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & id%S(1), MAXS, id%FILS(1), & id, id%root ) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF END IF IF ( I_AM_SLAVE ) THEN CALL DMUMPS_528(id%MYID_NODES) DMUMPS_LBUFR_BYTES = KEEP( 44 ) * KEEP( 35 ) DMUMPS_LBUFR_BYTES = max( DMUMPS_LBUFR_BYTES, & 100000 ) PERLU = KEEP( 12 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF DMUMPS_LBUFR_BYTES = DMUMPS_LBUFR_BYTES & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUFR_BYTES)/100D0) IF (KEEP(48)==5) THEN KEEP8(21) = KEEP8(22) + int( dble(max(PERLU,MIN_PERLU))* & dble(KEEP8(22))/100D0,8) ENDIF DMUMPS_LBUF = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(43)) * dble(KEEP(35)) ) DMUMPS_LBUF = max( DMUMPS_LBUF, 100000 ) DMUMPS_LBUF = DMUMPS_LBUF & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUF)/100D0) DMUMPS_LBUF = max(DMUMPS_LBUF, DMUMPS_LBUFR_BYTES+3*KEEP(34)) IF(id%KEEP(48).EQ.4)THEN DMUMPS_LBUFR_BYTES=DMUMPS_LBUFR_BYTES*5 DMUMPS_LBUF=DMUMPS_LBUF*5 ENDIF DMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN KKKK = MUMPS_275( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%NSLAVES ) IF ( KKKK .EQ. id%MYID_NODES ) THEN DMUMPS_LBUF_INT = DMUMPS_LBUF_INT + & 10 * & 2 * ( id%NE_STEPS(id%STEP(KEEP(38))) + 1 ) * id%NSLAVES & * KEEP(34) END IF END IF IF ( MP .GT. 0 ) 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) CALL DMUMPS_55( DMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID, & ':Error allocating small Send buffer:IERR=' & ,IERR INFO(1)= -13 INFO(2)= (DMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) GO TO 110 END IF CALL DMUMPS_53( DMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating Send buffer:IERR=' & ,IERR INFO(1)= -13 INFO(2)= (DMUMPS_LBUF+KEEP(34)-1)/KEEP(34) GO TO 110 END IF 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 WRITE(*,*) id%MYID,':Error allocating BUFR:IERR=' & ,IERR INFO(1)=-13 INFO(2)=id%LBUFR NULLIFY(id%BUFR) GO TO 110 END IF PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN MAXIS_ESTIM = KEEP(225) ELSE 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 WRITE(*,*) id%MYID,':Error allocating IS:IERR=',IERR INFO(1)=-13 INFO(2)=MAXIS NULLIFY(id%IS) GO TO 110 END IF LIW = MAXIS IF (associated( id%PTLUST_S )) DEALLOCATE(id%PTLUST_S) ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocatingPTLUST:IERR = ', & IERR INFO(1)=-13 INFO(2)=id%KEEP(28) 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 WRITE(*,*) id%MYID,':Error allocatingPTRFAC:IERR = ', & IERR INFO(1)=-13 INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) GOTO 100 END IF PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 3 * id%KEEP(28) IPOOL = ITLOC + id%N + id%KEEP(253) LPOOL = DMUMPS_505(id%KEEP(1),id%KEEP8(1)) ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', & IERR INFO(1)=-13 INFO(2)=IPOOL + LPOOL - 1 GOTO 110 END IF ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', & IERR INFO(1)=-13 INFO(2)=2 * id%KEEP(28) GOTO 110 END IF ENDIF 110 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN CALL DMUMPS_60( id%LBUFR_BYTES ) IF (MP .GT. 0) THEN WRITE( MP, 170 ) MAXS, MAXIS, KEEP8(12), KEEP(15), KEEP(13), & KEEP(14), KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF PERLU_ON = .TRUE. CALL DMUMPS_214( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) id%INFO(16) = TOTAL_MBYTES IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' ** Space in MBYTES used during factorization :', & id%INFO(16) END IF CALL MUMPS_243( 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 KEEP8(31)= 0_8 KEEP8(10) = 0_8 KEEP8(8)=0_8 INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = id%N ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT = id%NELT ELSE NELT = 1 END IF CALL DMUMPS_244( 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), INFO(1), RINFO(1), KEEP(1),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, 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) IF ( MP . GT. 0 .and. KEEP(38) .ne. 0 ) THEN WRITE( MP, 175 ) KEEP(49) END IF DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF IF ( KEEP(55) .eq. 0 ) THEN IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF ELSE DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN NULLIFY( id%DBLARR ) ELSE IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF END IF IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN 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 IF (associated(id%BUFR)) THEN DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) END IF CALL DMUMPS_57( IERR ) CALL DMUMPS_59( IERR ) IF (KEEP(219).NE.0) THEN CALL DMUMPS_620() ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) CALL DMUMPS_770(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_591(IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ENDIF ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) END IF END IF IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,180) TIME END IF PERLU_ON = .TRUE. CALL DMUMPS_214( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) KEEP8(7) = TOTAL_BYTES id%INFO(22) = TOTAL_MBYTES IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' ** Effective minimum Space in MBYTES for facto :', & TOTAL_MBYTES ENDIF IF (I_AM_SLAVE) THEN K67 = KEEP8(67) ELSE K67 = 0_8 ENDIF CALL MUMPS_735(K67,id%INFO(21)) CALL DMUMPS_713(PROKG, MPG, K67, id%NSLAVES, & id%COMM, "effective space used in S (KEEP8(67) =") CALL MUMPS_243( 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 KEEP(33) = INFO(11) CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_646( KEEP8(31),KEEP8(6), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(6), INFOG(9)) CALL MPI_REDUCE( INFO(10), INFOG(10), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_ALLREDUCE( INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) KEEP(133) = INFOG(11) CALL MPI_REDUCE( 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) INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) CALL MUMPS_646( KEEP8(8), KEEP8(108), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(10), INFO(27)) CALL MUMPS_646( KEEP8(10),KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(110), INFOG(29)) IF (KEEP(258).NE.0) THEN RINFOG(13)=0.0D0 IF (KEEP(260).EQ.-1) THEN id%DKEEP(6)=-id%DKEEP(6) ENDIF CALL DMUMPS_764( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN IF (id%KEEP(23).NE.0) THEN CALL DMUMPS_767( & RINFOG(12), id%N, & id%STEP(1), & id%UNS_PERM(1) ) ENDIF ENDIF ENDIF IF(KEEP(110) .EQ. 1) THEN INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF INFOG(28)=KEEP(112)+KEEP(17) IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN INFO(18)=INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN DO I=1, KEEP(17) id%PIVNUL_LIST(KEEP(112)+I)=id%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE 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 IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%NPROCS END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (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 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) 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 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) IF ( PROKG ) THEN WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP8(6),INFOG(10), & INFOG(11), KEEP8(110) IF (id%KEEP(50) == 1 .OR. id%KEEP(50) == 2) THEN WRITE(MPG, 99987) INFOG(12) END IF IF (id%KEEP(50) == 0) THEN WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN WRITE(MPG, 99986) KEEP(98) ENDIF IF (id%KEEP(50) == 2) THEN WRITE(MPG, 99988) KEEP(229) WRITE(MPG, 99989) KEEP(230) ENDIF IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) IF (KEEP(110).NE.0.OR.KEEP(17).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) WRITE(MPG, 99981) INFOG(14) IF ((KEEP(201).EQ.0.OR.KEEP(201).EQ.2).AND. & KEEP(50).EQ.0) THEN WRITE(MPG, 99980) KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN 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 500 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL DMUMPS_592(id,IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ELSE IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 END IF END IF 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL DMUMPS_183( INFO(1), IERR ) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) 530 CONTINUE IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) id%KEEP(13) = KEEP13_SAVE RETURN 120 FORMAT(/' LOCAL REDISTRIB: DATA LOCAL/SENT =',I12,I12) 125 FORMAT(/' REDISTRIB: TOTAL DATA LOCAL/SENT =',I12,I12) 130 FORMAT(/' ****** FACTORIZATION STEP ********'/) 160 FORMAT(' GLOBAL TIME FOR MATRIX DISTRIBUTION =',F12.4) 165 FORMAT(' Convergence error after scaling for INF-NORM', & ' (option 7/8) =',D9.2) 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 =',I12/ & ' Size of internal working array IS =',I12/ & ' MINIMUM (ICNTL(14)=0) size of S =',I12/ & ' MINIMUM (ICNTL(14)=0) size of IS =',I12/ & ' REAL SPACE FOR ORIGINAL MATRIX =',I12/ & ' INTEGER SPACE FOR ORIGINAL MATRIX =',I12/ & ' REAL SPACE FOR FACTORS =',I12/ & ' INTEGER SPACE FOR FACTORS =',I12/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12) 172 FORMAT(/' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' NUMBER OF WORKING PROCESSES =',I12/ & ' OUT-OF-CORE OPTION (ICNTL(22)) =',I12/ & ' REAL SPACE FOR FACTORS =',I12/ & ' INTEGER SPACE FOR FACTORS =',I12/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12/ & ' NUMBER OF NODES IN THE TREE =',I12) 173 FORMAT( ' PERFORM FORWARD DURING FACTO, NRHS =',I12) 175 FORMAT(/' NUMBER OF ENTRIES FOR // ROOT =',I12) 180 FORMAT(/' ELAPSED TIME FOR FACTORIZATION =',F12.4) 99977 FORMAT( ' INFOG(34) DETERMINANT (base 2 exponent) =',I12) 99978 FORMAT( ' RINFOG(12) DETERMINANT (real part) =',F12.4) 99980 FORMAT( ' KEEP8(108) Extra copies IP stacking =',I12) 99981 FORMAT( ' INFOG(14) NUMBER OF MEMORY COMPRESS =',I12) 99982 FORMAT( ' INFOG(13) NUMBER OF DELAYED PIVOTS =',I12) 99983 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(16) =',I12) 99991 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(24) =',I12) 99992 FORMAT( ' INFOG(28) ESTIMATED DEFICIENCY =',I12) 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 =',I12/ & ' INFOG(10) INTEGER SPACE FOR FACTORS =',I12/ & ' INFOG(11) MAXIMUM FRONT SIZE =',I12/ & ' INFOG(29) NUMBER OF ENTRIES IN FACTORS =',I12) 99985 FORMAT( ' INFOG(12) NB OF OFF DIAGONAL PIVOTS =',I12) 99986 FORMAT( ' INFOG(25) NB TINY PIVOTS/STATIC PIVOTING =',I12) 99987 FORMAT( ' INFOG(12) NB OF NEGATIVE PIVOTS =',I12) 99988 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 1 nodes =',I12) 99989 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 2 nodes =',I12) END SUBROUTINE DMUMPS_142 SUBROUTINE DMUMPS_713(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 INTEGER(8) MAX_VAL INTEGER IERR, MASTER DOUBLE PRECISION LOC_VAL, AVG_VAL PARAMETER(MASTER=0) CALL MUMPS_646( 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,I12) END SUBROUTINE DMUMPS_713 SUBROUTINE DMUMPS_770(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR, MASTER 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 INTEGER MUMPS_275 EXTERNAL MUMPS_275 IF (id%INFO(1) .LT. 0) RETURN IF (id%KEEP(60) .EQ. 0) RETURN ID_SCHUR =MUMPS_275( & 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 IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE LD_SCHUR = -999999 SIZE_SCHUR = id%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ELSE RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN 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 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 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 IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF RETURN ENDIF IF (id%KEEP(252).EQ.0) THEN IF ( ID_SCHUR .EQ. MASTER ) THEN CALL DMUMPS_756( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE BL8=int(huge(BL4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) IF ( id%MYID .eq. ID_SCHUR ) THEN 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 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 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 CALL dcopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_DOUBLE_PRECISION, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE 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 IF (id%KEEP(221).EQ.1) THEN 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 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 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_770 SUBROUTINE DMUMPS_83 & ( N, MAPPING, NZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NZ, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NZ ), JCN( NZ ) INTEGER MAPPING( NZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_275, MUMPS_330 EXTERNAL MUMPS_275, MUMPS_330 INTEGER K, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K INODE = FILS( INODE ) K = K + 1 END DO DO K = 1, NZ IOLD = IRN( K ) JOLD = JCN( K ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K ) = -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_330( PROCNODE(abs(STEP(IARR))), & SLAVEF ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_275( PROCNODE(abs(STEP(IARR))), & SLAVEF ) + 1 ELSE DEST = MUMPS_275( 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( K ) = DEST END DO RETURN END SUBROUTINE DMUMPS_83 SUBROUTINE DMUMPS_282( & N, NZ_loc, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND, NLOCAL, & ISTEP_TO_INIV2, CANDIDATES & ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NZ_loc TYPE (DMUMPS_STRUC) :: id INTEGER LDBLARR, LINTARR DOUBLE PRECISION DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER 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_275, MUMPS_330, numroc, & MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, numroc, & MUMPS_810 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ), MSGSOU DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER END_MSG_2_RECV INTEGER I, K, I1, IA 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 IACT( SLAVEF ), IREQI( SLAVEF ), IREQR( SLAVEF ) LOGICAL SEND_ACTIVE( SLAVEF ) LOGICAL FLAG INTEGER NSEND, NLOCAL INTEGER MASTER_NODE, ISTEP NSEND = 0 NLOCAL = 0 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF 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 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_276( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) RETURN ARROW_ROOT = 0 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((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 K = 1, NZ_loc 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_102( & 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(K) JOLD = id%JCN_loc(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) CYCLE VAL = id%A_loc(K) 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_330( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE= MUMPS_275( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_810( 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 NLOCAL = NLOCAL + 1 NSEND = NSEND + SLAVEF -1 else if (DEST .eq.MYID ) then NLOCAL = NLOCAL + 1 else NSEND = NSEND + 1 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_101( 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_101( 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_101( 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_101( 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_101( 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_101( 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_102( & 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 DEALLOCATE( IW4 ) DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) DEALLOCATE( BUFRECI ) DEALLOCATE( BUFRECR ) RETURN END SUBROUTINE DMUMPS_282 SUBROUTINE DMUMPS_101( 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 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 PTRAIW( N ), PTRARW( N ), 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, 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_102( & 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_102( & 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_101 SUBROUTINE DMUMPS_102 & ( 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 PTRAIW( N ), PTRARW( N ), PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA DOUBLE PRECISION A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID, & ILOCROOT, JLOCROOT INTEGER IA, IS1, ISHIFT, IIW, IS, IAS, 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_330( & 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 IA = PTRARW(IARR) DBLARR(IA) = DBLARR(IA) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL ENDIF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IPROC = MUMPS_275( 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_310( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE DMUMPS_102 SUBROUTINE DMUMPS_151( NRHS, N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER NRHS, N,LIWW,LWC,POSWCB,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28),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 SIZFR = SIZFR * NRHS IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE DMUMPS_151 SUBROUTINE DMUMPS_95(NRHS,N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER NRHS,N,LIWW,LWC,POSWCB,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28),PTRACB(KEEP28) DOUBLE PRECISION W(LWC) INTEGER IPTIW,IPTA,SIZFI,SIZFR,LONGI,LONGR INTEGER I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = IWCB(IPTIW+1) SIZFI = 2 SIZFR = SIZFR * NRHS IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I ) 20 CONTINUE DO 30 I=0,LONGR-1 W(IPTA + SIZFR - I) = W(IPTA - I ) 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 = IWCB(IPTIW+1) SIZFI = 2 SIZFR = SIZFR * NRHS IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE DMUMPS_95 SUBROUTINE DMUMPS_205(MTYPE, IFLAG, N, NZ, & LHS, WRHS, W, RHS, GIVSOL, SOL, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,NZ,IFLAG,ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION RHS(N),LHS(N) DOUBLE PRECISION WRHS(N),SOL(*) DOUBLE PRECISION W(N) DOUBLE PRECISION RESMAX,RESL2,XNORM, ERMAX,MAXSOL, & COMAX, SCLNRM, ERL2, ERREL DOUBLE PRECISION ANORM,DZERO,EPSI LOGICAL GIVSOL,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0D0 EPSI = 0.1D-9 ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RHS(K))) RESL2 = RESL2 + abs(RHS(K)) * abs(RHS(K)) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF (XNORM .GT. EPSI) THEN SCLNRM = RESMAX / (ANORM * XNORM) ELSE IFLAG = IFLAG + 2 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) &' max-NORM of computed solut. is zero' SCLNRM = RESMAX / ANORM ENDIF RESL2 = sqrt(RESL2) ERMAX = DZERO COMAX = DZERO ERL2 = DZERO IF (.NOT.GIVSOL) THEN IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM ELSE MAXSOL = DZERO DO 60 K = 1, N MAXSOL = max(MAXSOL, abs(SOL(K))) 60 CONTINUE DO 70 K = 1, N ERL2 = abs(LHS(K) - SOL(K)) ** 2 + ERL2 ERMAX = max(ERMAX, abs(LHS(K) - SOL(K))) 70 CONTINUE DO 80 K = 1, N IF (abs(SOL(K)) .GT. EPSI) THEN COMAX = max(COMAX, (abs(LHS(K) - SOL(K)) / abs(SOL(K)))) ENDIF 80 CONTINUE ERL2 = sqrt(ERL2) IF (MAXSOL .GT. EPSI) THEN ERREL = ERMAX / MAXSOL ELSE IFLAG = IFLAG + 2 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) &' MAX-NORM of exact solution is zero' ERREL = ERMAX ENDIF IF (PROK) WRITE( MPRINT, 100 ) ERMAX, ERL2, ERREL, COMAX, RESMAX & , RESL2, ANORM, XNORM, SCLNRM ENDIF 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 100 FORMAT (/' ERROR IS ............ (MAX-NORM) =',1PD9.2/ & ' ............ (2-NORM) =',1PD9.2/ & ' RELATIVE ERROR........... (MAX-NORM) =',1PD9.2/ & ' Comp. Wise ERROR......... (MAX-NORM) =',1PD9.2/ & ' AND RESIDUAL IS ......... (MAX-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' NORM OF input MATRIX ... (MAX-NORM) =',1PD9.2/ & ' NORM of computed SOLUT... (MAX-NORM) =',1PD9.2/ & ' SCALED RESIDUAL ......... (MAX-NORM) =',1PD9.2) END SUBROUTINE DMUMPS_205 SUBROUTINE DMUMPS_206(NZ, N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, JOB, COND, MAXIT, NOITER, LP, KEEP,KEEP8, & ARRET ) IMPLICIT NONE INTEGER NZ, N, KASE, KEEP(500), JOB 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, MAXIT, NOITER DOUBLE PRECISION COND(2),OMEGA(2) DOUBLE PRECISION ARRET DOUBLE PRECISION CGCE, CTAU DATA CTAU /1.0D3/, CGCE /0.2D0/ LOGICAL LCOND1, LCOND2 INTEGER IFLAG, JUMP, I, IMAX DOUBLE PRECISION ERX, DXMAX DOUBLE PRECISION CONVER, OM1, OM2, DXIMAX DOUBLE PRECISION ZERO, ONE,TAU, DD DOUBLE PRECISION OLDOMG(2) INTEGER DMUMPS_IXAMAX INTRINSIC abs, max SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX, CONVER, & OM1, OLDOMG, IFLAG DATA ZERO /0.0D0/, ONE /1.0D0/ IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO OM1 = ZERO IFLAG = 0 NOITER = 0 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 DO 20 I = 1, N X(I) = X(I) + Y(I) 20 CONTINUE IF (NOITER .GT. MAXIT) THEN IFLAG = IFLAG + 8 GOTO 70 ENDIF 30 CONTINUE KASE = 14 JUMP = 5 RETURN 35 CONTINUE IMAX = DMUMPS_IXAMAX(N, X, 1) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO 40 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 + TAU) .GT. TAU) 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 40 CONTINUE OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) GOTO 70 IF (MAXIT .EQ. 0) GOTO 70 IF (NOITER .GT. 1 .AND. OM2 .GT. OM1 * CGCE) THEN CONVER = OM2 / OM1 IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO 50 I = 1, N X(I) = C_W(I) 50 CONTINUE ENDIF GOTO 70 ENDIF DO 60 I = 1, N C_W(I) = X(I) 60 CONTINUE OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 NOITER = NOITER + 1 KASE = 2 JUMP = 2 RETURN 70 KASE = 0 IF (JOB .LE. 0) GOTO 170 DO 80 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 80 CONTINUE DO 90 I = 1, N C_W(I) = X(I) * D(I) 90 CONTINUE IMAX = DMUMPS_IXAMAX(N, C_W(1), 1) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CALL DMUMPS_218(N, KASE, Y, COND(1), C_W, IW(1, 2)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL DMUMPS_204(N, Y, D) IF (KASE .EQ. 2) CALL DMUMPS_204(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL DMUMPS_204(N, Y, R_W) IF (KASE .EQ. 2) CALL DMUMPS_204(N, Y, D) GOTO 100 120 IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CALL DMUMPS_218(N, KASE, Y, COND(2), C_W, IW(1, 2)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL DMUMPS_204(N, Y, D) IF (KASE .EQ. 2) CALL DMUMPS_204(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL DMUMPS_204(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL DMUMPS_204(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 KASE = -IFLAG RETURN END SUBROUTINE DMUMPS_206 SUBROUTINE DMUMPS_207(A, NZ, N, IRN, ICN, Z, KEEP,KEEP8) INTEGER NZ, N, I, J, K, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN(NZ), ICN(NZ) DOUBLE PRECISION A(NZ) DOUBLE PRECISION Z(N) DOUBLE PRECISION ZERO INTRINSIC abs DATA ZERO /0.0D0/ DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1, NZ 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, NZ 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 RETURN END SUBROUTINE DMUMPS_207 SUBROUTINE DMUMPS_289(A, NZ, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA) INTEGER, intent(in) :: NZ, N, KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) DOUBLE PRECISION, intent(in) :: A(NZ) DOUBLE PRECISION, intent(in) :: COLSCA(N) DOUBLE PRECISION, intent(out) :: Z(N) DOUBLE PRECISION ZERO DATA ZERO /0.0D0/ INTEGER I, J, K DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1, NZ 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, NZ 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_289 SUBROUTINE DMUMPS_208(A, NZ, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, intent(in) :: NZ, N, KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) DOUBLE PRECISION, intent(in) :: A(NZ), RHS(N), X(N) DOUBLE PRECISION, intent(out) :: W(N) DOUBLE PRECISION, intent(out) :: R(N) INTEGER I, K, J DOUBLE PRECISION ZERO DATA ZERO /0.0D0/ DOUBLE PRECISION D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. (J .LT. 1)) & CYCLE D = A(K) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF ((I.NE.J) .AND. (KEEP(50).NE.0) ) THEN D = A(K) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_208 SUBROUTINE DMUMPS_204(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_204 SUBROUTINE DMUMPS_218(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 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_218 SUBROUTINE DMUMPS_278( MTYPE, N, NZ, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N, NZ INTEGER IRN( NZ ), ICN( NZ ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, intent(in) :: ASPK( NZ ) DOUBLE PRECISION, intent(in) :: LHS( N ), WRHS( N ) DOUBLE PRECISION, intent(out):: RHS( N ) DOUBLE PRECISION, intent(out):: W( N ) INTEGER K, I, J DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) DO 10 K = 1, N W(K) = DZERO RHS(K) = WRHS(K) 10 CONTINUE IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(I) = RHS(I) - ASPK(K) * LHS(J) W(I) = W(I) + abs(ASPK(K)) ENDDO ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(J) = RHS(J) - ASPK(K) * LHS(I) W(J) = W(J) + abs(ASPK(K)) ENDDO ENDIF ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(I) = RHS(I) - ASPK(K) * LHS(J) W(I) = W(I) + abs(ASPK(K)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K) * LHS(I) W(J) = W(J) + abs(ASPK(K)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_278 SUBROUTINE DMUMPS_121( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION A_ELT(NA_ELT) DOUBLE PRECISION LHS( N ), WRHS( N ), RHS( N ) DOUBLE PRECISION W(N) CALL DMUMPS_257(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL DMUMPS_119( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE DMUMPS_121 SUBROUTINE DMUMPS_119( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION A_ELT(NA_ELT) DOUBLE PRECISION TEMP DOUBLE PRECISION W(N) INTEGER K, I, J, IEL, SIZEI, IELPTR DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K = 1 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( K )) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K)) K = K + 1 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( K )) K = K + 1 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K )) K = K + 1 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_119 SUBROUTINE DMUMPS_135(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION A_ELT(NA_ELT) DOUBLE PRECISION W(N) DOUBLE PRECISION TEMP, TEMP2 INTEGER K, I, J, IEL, SIZEI, IELPTR DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K = 1 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( K )) * TEMP2 K = K + 1 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( K )) * TEMP2 K = K + 1 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( K )*COLSCA(ELTVAR( IELPTR + J)) ) K = K + 1 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + I))) K = K + 1 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_135 SUBROUTINE DMUMPS_122( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR, NA_ELT INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) DOUBLE PRECISION A_ELT( NA_ELT ), 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_122 SUBROUTINE DMUMPS_643( & 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_726(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_578(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_577( & 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_682(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_643 SUBROUTINE DMUMPS_257( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) DOUBLE PRECISION A_ELT( * ), X( N ), Y( N ) INTEGER IEL, I , J, K, SIZEI, IELPTR DOUBLE PRECISION TEMP DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) Y = 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 K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & 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 ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE DMUMPS_257 SUBROUTINE DMUMPS_192 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE INTEGER N, NZ_loc INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) DOUBLE PRECISION A_loc( NZ_loc ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE INTEGER I, J, K DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ENDDO ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(I) ENDDO END IF ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE DMUMPS_192 SUBROUTINE DMUMPS_256( N, NZ, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM ) INTEGER N, NZ, LDLT, MTYPE, MAXTRANS INTEGER IRN( NZ ), ICN( NZ ) INTEGER PERM( N ) DOUBLE PRECISION ASPK( NZ ), X( N ), Y( N ) INTEGER K, I, J DOUBLE PRECISION PX( N ) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) Y = ZERO 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 IF (MTYPE .EQ. 1) THEN DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K) * PX(J) ENDDO ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K) * PX(I) ENDDO ENDIF ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K) * 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 RETURN END SUBROUTINE DMUMPS_256 SUBROUTINE DMUMPS_193 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE INTEGER N, NZ_loc INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) DOUBLE PRECISION A_loc( NZ_loc ), X( N ) DOUBLE PRECISION Y_loc( N ) INTEGER LDLT, MTYPE INTEGER I, J, K DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ) ENDDO ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(I) ) ENDDO END IF ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE DMUMPS_193 mumps-4.10.0.dfsg/src/zmumps_load.F0000644000175300017530000065321311562233070017342 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE ZMUMPS_LOAD implicit none PUBLIC :: ZMUMPS_188, ZMUMPS_185, & ZMUMPS_189, ZMUMPS_190, & ZMUMPS_183, ZMUMPS_187, & ZMUMPS_186, ZMUMPS_409, & ZMUMPS_384, ZMUMPS_461, & ZMUMPS_467, ZMUMPS_471, & ZMUMPS_472, & ZMUMPS_791, ZMUMPS_790, & ZMUMPS_792, ZMUMPS_500, & ZMUMPS_501, ZMUMPS_520, & ZMUMPS_513, & ZMUMPS_514, ZMUMPS_512 & ,ZMUMPS_533, & ZMUMPS_819, ZMUMPS_818, & ZMUMPS_820, ZMUMPS_554, & ZMUMPS_553, & ZMUMPS_555 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) INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: FUTURE_NIV2 DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM #else DOUBLE PRECISION, SAVE, PRIVATE :: LAST_LOAD_SENT, & DM_LAST_MEM_SENT #endif 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,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 ZMUMPS_188( COST_SUBTREE_ARG, K64, K66, & MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER K64, K66 INTEGER(8)::MAXS DOUBLE PRECISION T64, T66 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/1000_8) COST_SUBTREE = COST_SUBTREE_ARG END SUBROUTINE ZMUMPS_188 SUBROUTINE ZMUMPS_791 ( & 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_810 EXTERNAL MUMPS_810 LP = ICNTL(1) IN = INODE NBSPLIT = 0 NUMORG_SPLIT = 0 DO WHILE & ( & ( MUMPS_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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_791 SUBROUTINE ZMUMPS_790 ( & 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_810 EXTERNAL MUMPS_810 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_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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_790 SUBROUTINE ZMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & SON_SLAVE_LIST, NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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, & NCB, KEEP(500), NBSPLIT, & NSLSON, SIZE_SLAVES_LIST 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)) 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_792 SUBROUTINE ZMUMPS_472( & 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_499( & 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_504( & 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_545' CALL MUMPS_ABORT() ENDIF ENDDO ELSE IF ( KEEP(48) == 5 ) THEN CALL ZMUMPS_518( & 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_518' CALL MUMPS_ABORT() ENDIF ENDDO ELSE WRITE(*,*) "Strategy 6 not implemented" CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE ZMUMPS_472 SUBROUTINE ZMUMPS_499( & 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_12 EXTERNAL MUMPS_12 IF ( KEEP(48) == 0 .AND. KEEP(50) .NE. 0) THEN write(*,*) "Internal error 2 in ZMUMPS_499." CALL MUMPS_ABORT() END IF IF ( KEEP(48) == 3 .AND. KEEP(50) .EQ. 0) THEN write(*,*) "Internal error 3 in ZMUMPS_499." 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_409 & (MEM_DISTRIB, & CAND_OF_NODE, & & KEEP(69), SLAVEF, MSG_SIZE, & NMB_OF_CAND ) ELSE ITEMP=ZMUMPS_186(KEEP(69),MEM_DISTRIB,MSG_SIZE) NMB_OF_CAND = SLAVEF - 1 END IF NSLAVES_LESS = max(ITEMP,1) NSLAVES_NODE = MUMPS_12(KEEP8(21), KEEP(48), & KEEP(50),SLAVEF, & NCB, NFRONT, NSLAVES_LESS, NMB_OF_CAND) CALL MUMPS_441( & KEEP,KEEP8, SLAVEF, & TAB_POS, & NSLAVES_NODE, NFRONT, NCB & ) IF (FORCE_CAND) THEN CALL ZMUMPS_384(MEM_DISTRIB(0), & CAND_OF_NODE, SLAVEF, NSLAVES_NODE, & SLAVES_LIST) ELSE CALL ZMUMPS_189(MEM_DISTRIB(0), & MSG_SIZE, SLAVES_LIST, NSLAVES_NODE) ENDIF RETURN END SUBROUTINE ZMUMPS_499 SUBROUTINE ZMUMPS_185( id, MEMORY_MD_ARG, MAXS ) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_STRUC_DEF 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 INTEGER,DIMENSION(:),POINTER:: KEEP PARAMETER( ZERO=0.0d0 ) INTEGER WHAT INTEGER(8) MEMORY_MD, LA STEP_TO_NIV2_LOAD=>id%ISTEP_TO_INIV2 CAND_LOAD=>id%CANDIDATES ND_LOAD=>id%ND_STEPS KEEP_LOAD=>id%KEEP KEEP =>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 = KEEP(69) IF ( KEEP(47) .le. 0 .OR. KEEP(47) .gt. 4 ) THEN write(*,*) "Internal error 1 in ZMUMPS_185" CALL MUMPS_ABORT() END IF CHK_LD=dble(0) BDC_MEM = ( KEEP(47) >= 2 ) BDC_POOL = ( KEEP(47) >= 3 ) BDC_SBTR = ( KEEP(47) >= 4 ) BDC_M2_MEM = ( ( KEEP(80) == 2 .OR. KEEP(80) == 3 ) & .AND. KEEP(47) == 4 ) BDC_M2_FLOPS = ( KEEP(80) == 1 & .AND. KEEP(47) .GE. 1 ) BDC_MD = (KEEP(86)==1) SBTR_WHICH_M = KEEP(90) REMOVE_NODE_FLAG=.FALSE. REMOVE_NODE_FLAG_MEM=.FALSE. REMOVE_NODE_COST_MEM=dble(0) REMOVE_NODE_COST=dble(0) IF (KEEP(80) .LT. 0 .OR. KEEP(80)>3) THEN WRITE(*,*) "Unimplemented KEEP(80) Strategy" CALL MUMPS_ABORT() ENDIF IF ((KEEP(80) == 2 .OR. KEEP(80)==3 ).AND. KEEP(47).NE.4) & THEN WRITE(*,*) "Internal error 3 in ZMUMPS_185" CALL MUMPS_ABORT() END IF IF (KEEP(81) == 1 .AND. KEEP(47) < 2) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_185" CALL MUMPS_ABORT() ENDIF BDC_POOL_MNG = ((KEEP(81) == 1).AND.(KEEP(47) >= 2)) IF(KEEP(76).EQ.4)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST ENDIF IF(KEEP(76).EQ.5)THEN COST_TRAV=>id%COST_TRAV ENDIF IF(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 ALLOCATE(NIV2(id%NSLAVES), NB_SON(KEEP(28)), & POOL_NIV2(100),POOL_NIV2_COST(100), & stat=allocok) NB_SON=id%NE_STEPS NIV2=dble(0) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in ZMUMPS_185' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES + 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_185' 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_185' 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_185' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF LU_USAGE=dble(0) MD_MEM=int(0,8) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN ALLOCATE(CB_COST_MEM(2*2000*id%NSLAVES), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in ZMUMPS_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF SBTR_CUR = dble(0) SBTR_MEM = dble(0) END IF CALL MUMPS_546(K34_LOC,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_185' id%INFO(1) = -13 id%INFO(2) = LBUF_LOAD_RECV RETURN ENDIF BUF_LOAD_SIZE = BUF_LOAD_SIZE * 20 CALL ZMUMPS_54( 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_425(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_460( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEMORY_MD),dble(0) ,MYID, IERR ) WHAT=9 MEMORY_SENT = dble(LA-MAX_SURF_MASTER)-MAX_SBTR & - max( dble(LA) * dble(3) / dble(100), & dble(2) * dble(max(KEEP(5),KEEP(6))) * dble(KEEP(127))) IF (KEEP(12) > 25) THEN MEMORY_SENT = MEMORY_SENT - & dble(KEEP(12))*0.2d0*dble(LA)/100.0d0 ENDIF TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL ZMUMPS_460( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MEMORY_SENT, & dble(0),MYID, IERR ) ENDIF RETURN END SUBROUTINE ZMUMPS_185 SUBROUTINE ZMUMPS_190( CHECK_FLOPS,PROCESS_BANDE, & INC_LOAD, KEEP,KEEP8 ) USE ZMUMPS_COMM_BUFFER 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 (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_77( 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, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_190",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_190 SUBROUTINE ZMUMPS_471( SSARBR, & PROCESS_BANDE_ARG, MEM_VALUE, NEW_LU, INC_MEM_ARG, & KEEP,KEEP8,LRLU) USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_VALUE, INC_MEM_ARG, NEW_LU,LRLU 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 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_471." 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 #if defined(STATS_DYNAMIC_MEMORY) WRITE(*,*)MYID,': end of Incoherent state at time=', & MPI_WTIME()-TIME_REF #endif 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. #if defined(STATS_DYNAMIC_MEMORY) WRITE(*,*)MYID,': Begin of Incoherent state (1) at time=', & MPI_WTIME()-TIME_REF #endif 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_471', & 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.1d0*dble(LRLU))))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.1d0*dble(LRLU))))THEN IF ( abs( TMP_MEM-DM_LAST_MEM_SENT) > & DM_THRES_MEM ) THEN IERR = 0 SEND_MEM = TMP_MEM #endif 111 CONTINUE CALL ZMUMPS_77( & 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,IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_471",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_471 INTEGER FUNCTION ZMUMPS_186( 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_426(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_186 = NLESS RETURN END FUNCTION ZMUMPS_186 SUBROUTINE ZMUMPS_189(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_558(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_189 SUBROUTINE ZMUMPS_183( INFO1, IERR ) USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER, intent(in) :: INFO1 INTEGER, intent(out) :: IERR IERR=0 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_58( IERR ) CALL ZMUMPS_150( MYID, COMM_LD, & BUF_LOAD_RECV, LBUF_LOAD_RECV, & LBUF_LOAD_RECV_BYTES ) DEALLOCATE(BUF_LOAD_RECV) END SUBROUTINE ZMUMPS_183 #if defined (LAMPORT_) RECURSIVE SUBROUTINE ZMUMPS_467(COMM, KEEP) #else SUBROUTINE ZMUMPS_467(COMM, KEEP) #endif IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MSGTAG, MSGLEN, MSGSOU,COMM INTEGER KEEP(500) 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(65)=KEEP(65)+1 MSGTAG = STATUS( MPI_TAG ) MSGSOU = STATUS( MPI_SOURCE ) IF ( MSGTAG .NE. UPDATE_LOAD) THEN write(*,*) "Internal error 1 in ZMUMPS_467", & 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_467", & 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_187( MSGSOU, BUF_LOAD_RECV, & LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES ) GOTO 10 ENDIF RETURN END SUBROUTINE ZMUMPS_467 RECURSIVE SUBROUTINE ZMUMPS_187 & ( MSGSOU, BUFR, LBUFR, LBUFR_BYTES ) 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_330 INTEGER MUMPS_330 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_819(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_187" 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_187" 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_187" 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_816(INODE_RECEIVED) ELSEIF(BDC_M2_FLOPS) THEN CALL ZMUMPS_817(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_330(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_187" 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. & sqrt(epsilon(LOAD_RECEIVED)))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 WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() 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_187' 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_187' 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_187' 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_187" CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE ZMUMPS_187 integer function ZMUMPS_409 & (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_426(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_409 = nless return end function ZMUMPS_409 subroutine ZMUMPS_384 & (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_558 NMB_OF_CAND = CAND(SLAVEF+1) if(nslaves_inode.ge.NPROCS .or. & nslaves_inode.gt.NMB_OF_CAND) then write(*,*)'Internal error in ZMUMPS_384', & 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_558(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_384 SUBROUTINE ZMUMPS_425(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_425 SUBROUTINE ZMUMPS_426(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_426 SUBROUTINE ZMUMPS_461(MYID, SLAVEF, COMM, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, NSLAVES,INODE) USE ZMUMPS_COMM_BUFFER 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 DOUBLE PRECISION MEM_INCREMENT ( NSLAVES ) DOUBLE PRECISION FLOPS_INCREMENT( NSLAVES ) DOUBLE PRECISION CB_BAND( NSLAVES ) IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN WHAT=1 ELSE WHAT=19 ENDIF #if ! defined(OLD_LOAD_MECHANISM) FUTURE_NIV2(MYID+1) = FUTURE_NIV2(MYID+1) - 1 IF ( FUTURE_NIV2(MYID+1) < 0 ) THEN WRITE(*,*) "Internal error in ZMUMPS_461" CALL MUMPS_ABORT() ENDIF IF ( FUTURE_NIV2(MYID + 1) == 0 ) THEN 112 CONTINUE CALL ZMUMPS_502(COMM,MYID,SLAVEF, & dble(MAX_SURF_MASTER),IERR) IF (IERR == -1 ) THEN CALL ZMUMPS_467(COMM_LD, KEEP) GOTO 112 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_461", & IERR CALL MUMPS_ABORT() ENDIF TAB_MAXS(MYID) = TAB_MAXS(MYID) + int(MAX_SURF_MASTER,8) ENDIF #endif IF ( NSLAVES /= TAB_POS(SLAVEF + 2) ) THEN write(*,*) "Error 1 in ZMUMPS_461", & 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_524(BDC_MEM, COMM, MYID, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT,IERR) IF ( IERR == -1 ) THEN CALL ZMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_461", & 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 RETURN END SUBROUTINE ZMUMPS_461 SUBROUTINE ZMUMPS_500( & POOL, LPOOL, & PROCNODE, KEEP,KEEP8, SLAVEF, COMM, MYID, STEP, N, & ND, FILS ) USE ZMUMPS_COMM_BUFFER 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_330 EXTERNAL MUMPS_330 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_330( 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_460( WHAT, & COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0),MYID, IERR ) POOL_LAST_COST_SENT = COST POOL_MEM(MYID)=COST IF ( IERR == -1 )THEN CALL ZMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_500", & IERR CALL MUMPS_ABORT() ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_500 SUBROUTINE ZMUMPS_501( & OK,INODE,POOL,LPOOL,MYID,SLAVEF,COMM,KEEP,KEEP8) USE ZMUMPS_COMM_BUFFER 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_283,MUMPS_170 LOGICAL MUMPS_283,MUMPS_170 IF((INODE.LE.0).OR.(INODE.GT.N_LOAD)) THEN RETURN ENDIF IF (.NOT.MUMPS_170( & PROCNODE_LOAD(STEP_LOAD(INODE)), NPROCS) & ) THEN RETURN ENDIF IF(MUMPS_283(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_460( & WHAT, COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0),MYID, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 1 in ZMUMPS_501", & 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_460( & WHAT, COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0) ,MYID,IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_467(COMM_LD, KEEP) GOTO 112 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 3 in ZMUMPS_501", & 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_501 SUBROUTINE ZMUMPS_504 & (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_504" 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_558(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_558(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 #if defined (OLD_PART) 887 CONTINUE #endif 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_504" 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_504" 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_504' 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_504' 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_504' 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 #if ! defined (OLD_PART) i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 #if ! defined (PART1_) 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_504' 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 #endif 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 #if ! defined (PART1_) ENDIF #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 ! defined (PART1_) 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 #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 #else DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/ & dble(i)).NE.0)THEN GOTO 555 ENDIF ENDDO 555 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(i)) DO J=1,i IF(NB_ROWS(J)+X.GT.K821/NCB)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & ((K821/NCB)-NB_ROWS(J)) NB_ROWS(J)=(K821/NFRONT) ELSE IF ((TEMP(J)+dble((NB_ROWS(J)+X))* & dble(NFRONT)).GT. & PEAK)THEN AFFECTED=int((PEAK-(TEMP(J)+dble(NB_ROWS(J))* & dble(NFRONT))/dble(NFRONT)) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED NB_ROWS(J)=NB_ROWS(J)+AFFECTED ELSE NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDIF IF(((TEMP(J)+dble(NB_ROWS(J))*dble(NFRONT)) & .GT. PEAK) & .AND.(SMALL_SET.LT.OTHERS))THEN WRITE(*,*)MYID, & ':Internal error 8 in ZMUMPS_504' SMALL_SET=SMALL_SET+1 CALL MUMPS_ABORT() ENDIF ENDDO SOMME=dble(0) DO J=1,CHOSEN SOMME=SOMME+NB_ROWS(J) ENDDO IF(ADDITIONNAL_ROWS.NE.0) THEN DO J=1,CHOSEN IF(NB_ROWS(J).LT.0)THEN WRITE(*,*)MYID, & ':Internal error 9 in ZMUMPS_504' CALL MUMPS_ABORT() ENDIF IF ((TEMP(J)+dble(NB_ROWS(J)) & *dble(NFRONT)).GT. & PEAK)THEN WRITE(*,*)MYID, & ':Internal error 10 in ZMUMPS_504' CALL MUMPS_ABORT() ENDIF IF ((TEMP(J)+dble(NB_ROWS(J)+ & ADDITIONNAL_ROWS)*dble(NFRONT)).GE. & PEAK)THEN AFFECTED=int((PEAK-(TEMP(J)+ & dble(NB_ROWS(J))* & dble(NFRONT))/dble(NFRONT)) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED NB_ROWS(J)=NB_ROWS(J)+AFFECTED IF((TEMP(J)+dble(NFRONT)* & dble(NB_ROWS(J))).GT. & PEAK)THEN WRITE(*,*)MYID, & ':Internal error 11 in ZMUMPS_504' CALL MUMPS_ABORT() ENDIF ELSE NB_ROWS(J)=NB_ROWS(J)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 666 ENDDO IF(SMALL_SET.EQ.(NUMBER_OF_PROCS)) THEN NB_ROWS=0 GOTO 887 ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF(NB_ROWS(i)+ADDITIONNAL_ROWS.LT.K821/NFRONT) & THEN NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-(K821/ & NFRONT & -NB_ROWS(i)) NB_ROWS(i)=K821/NFRONT ENDIF i=i+1 ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/dble(i)) & .NE.0)THEN GOTO 372 ENDIF ENDDO 372 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 ENDIF #endif 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_504' CALL MUMPS_ABORT() ENDIF CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*) & 'Internal error 13 in ZMUMPS_504' 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_504' 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_504' CALL MUMPS_ABORT() ENDIF END SUBROUTINE ZMUMPS_504 SUBROUTINE ZMUMPS_518 & (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_442 INTEGER MUMPS_442 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_442(int(NCB,8)*int(KMAX,8),K50,KMAX,NCB) NB_ROWS=0 CALL MUMPS_558(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_511(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_558(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 #if ! defined (OOC_PAR_MEM_SLAVE_SELECT) && ! defined (OOC_PAR_MEM2) CALL MUMPS_503(WHAT, KEEP,KEEP8, NCB, & NFRONT, min(NCB,OTHERS), J, X8) #endif 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_558(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_518' 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_518' 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_518' 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_518' 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_558(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_518' 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_558(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_518' 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_518' CALL MUMPS_ABORT() ENDIF X=X+1 ENDIF ENDDO DO i=CHOSEN+1,NUMBER_OF_PROCS SLAVES_LIST(i)=TEMP_ID(i) ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*)MYID, & ': Internal error 17 in ZMUMPS_518', & POS,NCB+1 CALL MUMPS_ABORT() ENDIF END SUBROUTINE ZMUMPS_518 SUBROUTINE ZMUMPS_520 & (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_508, & MUMPS_170 LOGICAL ZMUMPS_508, & MUMPS_170 NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF(KEEP(47).LT.2)THEN WRITE(*,*)'ZMUMPS_520 must & be called with K47>=2' CALL MUMPS_ABORT() ENDIF IF((INODE.GT.0).AND.(INODE.LE.N))THEN MEM_COST=ZMUMPS_543(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_543(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_170(PROCNODE(STEP(INODE)), & SLAVEF))THEN WRITE(*,*) & 'Internal error 1 in ZMUMPS_520' CALL MUMPS_ABORT() ENDIF UPPER=.FALSE. RETURN ENDIF INODE=POOL(LPOOL-2-NBTOP) UPPER=.TRUE. RETURN ENDIF ENDIF UPPER=.TRUE. END SUBROUTINE ZMUMPS_520 SUBROUTINE ZMUMPS_513(WHAT) IMPLICIT NONE LOGICAL WHAT IF(.NOT.BDC_POOL_MNG)THEN WRITE(*,*)'ZMUMPS_513 & 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_513 DOUBLE PRECISION FUNCTION ZMUMPS_543( INODE ) IMPLICIT NONE INTEGER INODE,LEVEL,i,NELIM,NFR DOUBLE PRECISION COST EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_330( 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_543=COST RETURN END FUNCTION ZMUMPS_543 RECURSIVE SUBROUTINE ZMUMPS_515(FLAG,COST,COMM) USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL FLAG DOUBLE PRECISION COST DOUBLE PRECISION TO_BE_SENT EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_460( WHAT, & COMM, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, & TO_BE_SENT, & MYID, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_467(COMM_LD, KEEP_LOAD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_500", & IERR CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE ZMUMPS_515 SUBROUTINE ZMUMPS_512(INODE,STEP,NSTEPS,PROCNODE,FRERE, & NE,COMM,SLAVEF,MYID,KEEP,KEEP8,N) USE ZMUMPS_COMM_BUFFER 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_170,MUMPS_275 LOGICAL MUMPS_170 INTEGER i,NCB,NELIM INTEGER MUMPS_275 INTEGER FATHER_NODE,FATHER,WHAT,IERR EXTERNAL MUMPS_330 INTEGER MUMPS_330 IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*)MYID,': Problem in ZMUMPS_512' 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_170(PROCNODE(STEP(FATHER_NODE)), & SLAVEF)) THEN RETURN ENDIF FATHER=MUMPS_275(PROCNODE(STEP(FATHER_NODE)),SLAVEF) IF(FATHER.EQ.MYID)THEN IF(BDC_M2_MEM)THEN CALL ZMUMPS_816(FATHER_NODE) ELSEIF(BDC_M2_FLOPS)THEN CALL ZMUMPS_817(FATHER_NODE) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN IF(MUMPS_330(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_519(WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB, KEEP(81),MYID, & FATHER, IERR) IF (IERR == -1 ) THEN CALL ZMUMPS_467(COMM, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_512", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE END SUBROUTINE ZMUMPS_512 SUBROUTINE ZMUMPS_514(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_515(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_515(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_514 RECURSIVE SUBROUTINE ZMUMPS_816(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_816' 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 POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & ZMUMPS_543(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_515(REMOVE_NODE_FLAG_MEM,MAX_M2,COMM_LD) NIV2(1+MYID)=MAX_M2 ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_816 RECURSIVE SUBROUTINE ZMUMPS_817(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_817' 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 POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & ZMUMPS_542(INODE) POOL_SIZE=POOL_SIZE+1 MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL ZMUMPS_515(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_817 DOUBLE PRECISION FUNCTION ZMUMPS_542(INODE) INTEGER INODE INTEGER NFRONT,NELIM,i,LEVEL EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_330( PROCNODE_LOAD(STEP_LOAD(INODE)), NPROCS ) COST=dble(0) CALL MUMPS_511(NFRONT,NELIM,NELIM, & KEEP_LOAD(50),LEVEL,COST) ZMUMPS_542=COST RETURN END FUNCTION ZMUMPS_542 INTEGER FUNCTION ZMUMPS_541( 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_541=COST_CB RETURN END FUNCTION ZMUMPS_541 SUBROUTINE ZMUMPS_533(SLAVEF,NMB_OF_CAND, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, & NSLAVES,INODE) USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, NASS, NSLAVES INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, intent(in) :: NMB_OF_CAND INTEGER, INTENT (IN) :: LIST_SLAVES( NMB_OF_CAND ) INTEGER KEEP(500),INODE INTEGER(8) KEEP8(150) INTEGER allocok DOUBLE PRECISION MEM_COST,FCT_COST DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE ::EMPTY_ARRAY, & DELTA_MD,EMPTY_ARRAY2 INTEGER NBROWS_SLAVE,i,WHAT,IERR,NPROCS_LOC LOGICAL FORCE_CAND MEM_COST=dble(0) FCT_COST=dble(0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. NPROCS_LOC=SLAVEF-1 ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) NPROCS_LOC=NMB_OF_CAND END IF IF(FORCE_CAND)THEN CALL ZMUMPS_540(INODE,FCT_COST, & MEM_COST,NPROCS_LOC,NASS) ELSE CALL ZMUMPS_540(INODE,FCT_COST, & MEM_COST,SLAVEF-1,NASS) ENDIF DO i=1,SLAVEF IDWLOAD(i)=i-1 ENDDO ALLOCATE(EMPTY_ARRAY(NPROCS_LOC),DELTA_MD(NPROCS_LOC), & EMPTY_ARRAY2(NPROCS_LOC), & stat=allocok) DO i = 1, NSLAVES NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) DELTA_MD( i ) = FCT_COST - dble(NBROWS_SLAVE)* & dble(NASS) END DO IF(FORCE_CAND)THEN DO i=NSLAVES+1,NPROCS_LOC DELTA_MD( i ) = FCT_COST ENDDO ELSE DO i=NSLAVES+1,SLAVEF-1 DELTA_MD( i ) = FCT_COST ENDDO ENDIF WHAT=7 111 CONTINUE CALL ZMUMPS_524(.FALSE., COMM_LD, MYID, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NPROCS_LOC, LIST_SLAVES,0, & EMPTY_ARRAY, & DELTA_MD,EMPTY_ARRAY2,WHAT, IERR) IF ( IERR == -1 ) THEN CALL ZMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_533", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif DO i = 1, NSLAVES MD_MEM(LIST_SLAVES(i))=MD_MEM(LIST_SLAVES(i))+ & int(DELTA_MD( 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 ENDDO #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif DEALLOCATE(EMPTY_ARRAY) DEALLOCATE(DELTA_MD) END SUBROUTINE ZMUMPS_533 SUBROUTINE ZMUMPS_540(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_540 SUBROUTINE ZMUMPS_819(INODE) IMPLICIT NONE INTEGER INODE INTEGER i,J,SON,NSLAVES_TEMP,POS_TEMP,K INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_275( & 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_819 SUBROUTINE ZMUMPS_820(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_820 SUBROUTINE ZMUMPS_554(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_554 SUBROUTINE ZMUMPS_818(INODE,MAX_MEM,PROC) IMPLICIT NONE INTEGER INODE,PROC INTEGER i,POS,NSLAVES,SLAVE,NCAND,J,NELIM,NCB,NFRONT,SON,K INTEGER allocok EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_818' CALL MUMPS_ABORT() ENDIF ALLOCATE( CONCERNED(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_818' CALL MUMPS_ABORT() ENDIF ALLOCATE( RECV_BUF(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_818' 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_330(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_543(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_330(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_818' 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_818 SUBROUTINE ZMUMPS_553(MIN_PROC,POOL, & LPOOL,INODE) IMPLICIT NONE INTEGER INODE,LPOOL,MIN_PROC INTEGER POOL(LPOOL) EXTERNAL MUMPS_275 INTEGER MUMPS_275 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_275(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_275(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_553 SUBROUTINE ZMUMPS_555(POOL, LPOOL,KEEP,KEEP8) IMPLICIT NONE INTEGER LPOOL,POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER i,POS EXTERNAL MUMPS_283 LOGICAL MUMPS_283 IF(.NOT.BDC_SBTR) RETURN POS=0 DO i=NB_SUBTREES,1,-1 DO WHILE(MUMPS_283( & 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_555 END MODULE ZMUMPS_LOAD mumps-4.10.0.dfsg/src/smumps_part1.F0000644000175300017530000063773711562233064017463 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE SMUMPS( id ) USE SMUMPS_OOC USE SMUMPS_STRUC_DEF IMPLICIT NONE C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), INTERFACE SUBROUTINE SMUMPS_758 &(idRHS, idINFO, idN, idNRHS, idLRHS) REAL, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE SMUMPS_758 SUBROUTINE SMUMPS_26( id ) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id END SUBROUTINE SMUMPS_26 SUBROUTINE SMUMPS_142( id ) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id END SUBROUTINE SMUMPS_142 SUBROUTINE SMUMPS_301( id ) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id END SUBROUTINE SMUMPS_301 SUBROUTINE SMUMPS_349(id, LP) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE SMUMPS_349 END INTERFACE INCLUDE 'mpif.h' INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE (SMUMPS_STRUC) :: id INTEGER JOBMIN, JOBMAX, OLDJOB INTEGER I, J, MP, LP, MPG, KEEP235SAVE, KEEP242SAVE, & KEEP243SAVE LOGICAL LANAL, LFACTO, LSOLVE, PROK, FLAG, PROKG LOGICAL NOERRORBEFOREPERM LOGICAL UNS_PERM_DONE INTEGER COMM_SAVE INTEGER JOB, N, NZ, NELT INTEGER, PARAMETER :: ICNTL18DIST_MIN = 1 INTEGER, PARAMETER :: ICNTL18DIST_MAX = 3 INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV NOERRORBEFOREPERM = .FALSE. UNS_PERM_DONE = .FALSE. JOB = id%JOB N = id%N NZ = id%NZ NELT = id%NELT id%INFO(1) = 0 id%INFO(2) = 0 IF ( JOB .NE. -1 ) THEN LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.3)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (PROKG) THEN IF (id%ICNTL(5) .NE. 1) THEN WRITE(MPG,'(A,I4,I12,I15)') & 'Entering SMUMPS driver with JOB, N, NZ =', JOB,N,NZ ELSE WRITE(MPG,'(A,I4,I12,I15)') & 'Entering SMUMPS driver with JOB, N, NELT =', JOB,N & ,NELT ENDIF ENDIF ELSE MPG = 0 PROK = .FALSE. PROKG = .FALSE. LP = 6 MP = 6 END IF CALL MPI_INITIALIZED( FLAG, IERR ) IF ( .NOT. FLAG ) THEN WRITE(LP,990) 990 FORMAT(' Error in SMUMPS initialization: MPI is not running.') id%INFO(1) = -23 id%INFO(2) = 0 GOTO 500 END IF COMM_SAVE = id%COMM CALL MPI_COMM_DUP( COMM_SAVE, id%COMM, IERR ) CALL MPI_ALLREDUCE(JOB,JOBMIN,1,MPI_INTEGER,MPI_MAX, & id%COMM,IERR) CALL MPI_ALLREDUCE(JOB,JOBMAX,1,MPI_INTEGER,MPI_MIN, & id%COMM,IERR) IF ( JOBMIN .NE. JOBMAX ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF ( JOB .EQ. -1 ) THEN id%INFO(1)=0 id%INFO(2)=0 IF ( id%KEEP(40) .EQ. 1 - 456789 .OR. & id%KEEP(40) .EQ. 2 - 456789 .OR. & id%KEEP(40) .EQ. 3 -456789 ) THEN IF ( id%N > 0 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ENDIF ENDIF CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR) CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) THEN IF (id%KEEP(201).GT.0) THEN CALL SMUMPS_587(id, IERR) ENDIF GOTO 499 ENDIF CALL SMUMPS_163( id ) GOTO 500 END IF IF ( JOB .EQ. -2 ) THEN id%KEEP(40)= -2 - 456789 CALL SMUMPS_136( id ) GOTO 500 END IF IF ((JOB.LT.1).OR.(JOB.GT.6)) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF (id%MYID.EQ.MASTER) THEN IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN IF ((N.LE.0).OR.((N+N+N)/3.NE.N)) THEN id%INFO(1) = -16 id%INFO(2) = N END IF IF (id%ICNTL(5).NE.1) THEN IF (NZ.LE.0) THEN id%INFO(1) = -2 id%INFO(2) = NZ END IF ELSE IF (NELT.LE.0) THEN id%INFO(1) = -24 id%INFO(2) = NELT END IF ENDIF END IF IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF END IF CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 LANAL = .FALSE. LFACTO = .FALSE. LSOLVE = .FALSE. IF ((JOB.EQ.1).OR.(JOB.EQ.4).OR. & (JOB.EQ.6)) LANAL = .TRUE. IF ((JOB.EQ.2).OR.(JOB.EQ.4).OR. & (JOB.EQ.5).OR.(JOB.EQ.6)) LFACTO = .TRUE. IF ((JOB.EQ.3).OR.(JOB.EQ.5).OR. & (JOB.EQ.6)) LSOLVE = .TRUE. IF (MP.GT.0) CALL SMUMPS_349(id, MP) OLDJOB = id%KEEP( 40 ) + 456789 IF ( LANAL ) THEN 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 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 IF ( OLDJOB .LT. 1 .and. .NOT. LANAL ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF IF ( LSOLVE ) THEN IF ( OLDJOB .LT. 2 .AND. .NOT. LFACTO ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF #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 id%INFO(1)=-13 id%INFO(2)=id%N IF (id%ICNTL(1) .GT. 0 .AND. id%ICNTL(4) .GE.1) THEN WRITE(id%ICNTL(2),99993) END IF GOTO 510 ENDIF DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I END DO DO I = 1, id%NZ J = id%JCN(I) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I)=UNS_PERM_INV(J) END DO DEALLOCATE(UNS_PERM_INV) END IF END IF #endif CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 IF (LANAL) THEN id%KEEP(40)=-1 -456789 IF (id%MYID.EQ.MASTER) THEN id%INFOG(7) = -9999 id%INFOG(23) = 0 id%INFOG(24) = 1 IF (associated(id%IS1)) DEALLOCATE(id%IS1) IF ( id%ICNTL(5) .NE. 1 ) THEN 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 = 11 * N ELSE id%MAXIS1 = 10 * N END IF ELSE id%MAXIS1 = 6 * N + 2 * NELT + 2 ENDIF ALLOCATE( id%IS1(id%MAXIS1), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%MAXIS1 IF ( LP .GT.0 ) & WRITE(LP,*) 'Problem in allocating work array for analysis.' GO TO 100 END IF 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 ( LP .GT. 0 ) THEN WRITE(LP,*) 'Problem in allocating work array PROCNODE' END IF GOTO 100 END IF id%PROCNODE(1:id%N) = 0 IF ( id%ICNTL(5) .EQ. 1 ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP,*) 'Problem in allocating work array ELTPROC' END IF GOTO 100 END IF END IF IF ( id%ICNTL(5) .NE. 1 ) THEN id%NA_ELT=0 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 ELSE IF ( size( id%IRN ) < id%NZ ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE IF ( size( id%JCN ) < id%NZ ) THEN id%INFO(1) = -22 id%INFO(2) = 2 END IF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF (LP.GT.0) WRITE(LP,*) & '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 id%NA_ELT = 0 IF ( id%KEEP(50) .EQ. 0 ) THEN DO I = 1,NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) J = (J * J) id%NA_ELT = id%NA_ELT + J ENDDO ELSE DO I = 1,NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) J = (J * (J+1))/2 id%NA_ELT = id%NA_ELT + J ENDDO ENDIF ENDIF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF (LP.GT.0) WRITE(LP,*) & 'Error in analysis: ELTPTR/ELTVAR badly allocated.' END IF ENDIF 100 CONTINUE END IF CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(52) = id%ICNTL(8) IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 CALL SMUMPS_26( id ) 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 IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF IF (LFACTO) THEN id%KEEP(40) = 1 - 456789 IF ( id%MYID .EQ. MASTER ) THEN IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN id%SCHUR=>id%SCHUR_CINTERFACE & (1:id%SIZE_SCHUR*id%SIZE_SCHUR) 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 IF ( id%KEEP(55) .EQ. 0 ) THEN IF ( id%KEEP(54).eq.0 ) THEN IF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE IF ( size( id%A ) < id%NZ ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF END IF ELSE IF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE IF ( size( id%A_ELT ) < id%NA_ELT ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF CALL MUMPS_633(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) CALL SMUMPS_635(N,id%KEEP(1),id%ICNTL(1),MPG) 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.77) THEN IF (id%KEEP(50).EQ.1) THEN id%KEEP(52) = 0 ELSE 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 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 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 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 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 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 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 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(N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 END IF 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 ( LP .GT. 0 ) & WRITE(LP,*) 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL SMUMPS_758 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) CALL SMUMPS_807(id) CALL SMUMPS_769(id) ENDIF 200 CONTINUE END IF CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( id%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN id%SCHUR=>id%SCHUR_CINTERFACE & (1:id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) ENDIF 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 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 CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL SMUMPS_142(id) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) 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 IF ( id%INFO(1) .LT. 0 ) GO TO 499 id%KEEP(40) = 2 - 456789 END IF IF (LSOLVE) THEN id%KEEP(40) = 2 -456789 IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 ENDIF CALL SMUMPS_301(id) IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 id%KEEP(40) = 3 -456789 ENDIF IF (MP.GT.0) CALL SMUMPS_349(id, MP) GOTO 500 499 PROK = ((id%ICNTL(1).GT.0).AND. & (id%ICNTL(4).GE.1)) IF (PROK) WRITE (id%ICNTL(1),99995) id%INFO(1) IF (PROK) WRITE (id%ICNTL(1),99994) id%INFO(2) 500 CONTINUE #if ! defined(LARGEMATRICES) IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN IF (id%JOB .NE. 3 .OR. UNS_PERM_DONE) THEN DO I = 1, id%NZ J=id%JCN(I) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I)=id%UNS_PERM(J) END DO END IF END IF #endif 510 CONTINUE CALL SMUMPS_300(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) CALL MPI_BCAST( id%RINFOG(1), 40, MPI_REAL, MASTER, & id%COMM, IERR ) IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I12)') ' On return from SMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I12)') ' On return from SMUMPS, INFOG(2)=', & id%INFOG(2) END IF CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE RETURN 99995 FORMAT (' ** ERROR RETURN ** FROM SMUMPS INFO(1)=', I3) 99994 FORMAT (' ** INFO(2)=', I10) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE SMUMPS SUBROUTINE SMUMPS_300( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INFO(40), INFOG(40), COMM, MYID INTEGER TMP1(2),TMP(2) INTEGER ROOT, IERR INTEGER MASTER PARAMETER (MASTER=0) IF ( INFO(1) .ge. 0 .and. INFO(2) .ge. 0 ) THEN INFOG(1) = INFO(1) INFOG(2) = INFO(2) ELSE INFOG(1) = INFO(1) 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 CALL MPI_BCAST(INFOG(3), 38, MPI_INTEGER, MASTER, COMM, IERR ) RETURN END SUBROUTINE SMUMPS_300 SUBROUTINE SMUMPS_349(id, LP) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LT.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) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SHUR) =',I10) END SUBROUTINE SMUMPS_349 SUBROUTINE SMUMPS_350(id, LP) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LT.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_350 SUBROUTINE SMUMPS_758 & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE 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_758 SUBROUTINE SMUMPS_807(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE 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_807 SUBROUTINE SMUMPS_769(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE 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 RETURN END SUBROUTINE SMUMPS_769 SUBROUTINE SMUMPS_24( 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 ), & 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_330, MUMPS_275, MUMPS_810 EXTERNAL MUMPS_330, MUMPS_275, MUMPS_810 INTEGER ISTEP, I, IPTRI, IPTRR, NCOL, NROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) KEEP(14) = 0 KEEP(13) = 0 DO I = 1, N ISTEP=abs(STEP(I)) ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_810 ( 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. 1.OR.ITYPE.EQ.2) .AND. & IRANK .EQ. MYID ) & .OR. & ( T4_MASTER_CONCERNED ) & ) THEN KEEP( 14 ) = KEEP( 14 ) + 3 + PTRAIW( I ) + PTRARW( I ) KEEP( 13 ) = KEEP( 13 ) + 1 + PTRAIW( I ) + PTRARW( I ) ELSE IF ( ITYPE .EQ. 3 ) THEN ELSE IF ( ITYPE .EQ. 2 .AND. I_AM_CAND_LOC ) THEN PTRARW( I ) = 0 KEEP(14) = KEEP(14) + 3 + PTRAIW( I ) + PTRARW( I ) KEEP(13) = KEEP(13) + 1 + PTRAIW( I ) + PTRARW( I ) END IF END DO IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( KEEP(14) > 0 ) THEN ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = KEEP(14) 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 IPTRR = 1 DO I = 1, N ISTEP = abs(STEP(I)) ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_810 ( 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 = PTRAIW( I ) NROW = PTRARW( I ) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + NCOL + NROW + 3 IPTRR = IPTRR + NCOL + NROW + 1 ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NCOL = 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 + NCOL + NROW + 3 IPTRR = IPTRR + NCOL + NROW + 1 ELSE PTRAIW(I) = 0 PTRARW(I) = 0 END IF END DO IF ( IPTRI - 1 .NE. KEEP(14) ) THEN WRITE(*,*) 'Error 1 in anal_arrowheads', & ' IPTRI - 1, KEEP(14)=', IPTRI - 1, KEEP(14) CALL MUMPS_ABORT() END IF IF ( IPTRR - 1 .NE. KEEP(13) ) THEN WRITE(*,*) 'Error 2 in anal_arrowheads' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE SMUMPS_24 SUBROUTINE SMUMPS_148(N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & LP, COMM, root, KEEP, KEEP8, FILS, RG2L, & INTARR, DBLARR, PTRAIW, PTRARW, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES ) IMPLICIT NONE INCLUDE 'smumps_root.h' INTEGER N,NZ, COMM, NBRECORDS 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) :: LA INTEGER PTRAIW( N ), PTRARW( N ), FRERE_STEPS( KEEP(28) ) INTEGER STEP(N) INTEGER INTARR( max(1,KEEP(14)) ) REAL A( LA ), DBLARR(max(1,KEEP(13))) INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI REAL, DIMENSION(:,:), ALLOCATABLE :: BUFR INTEGER MUMPS_275, MUMPS_330, numroc, & MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, numroc, & MUMPS_810 REAL VAL INTEGER IOLD,JOLD,INEW,JNEW,ISEND,JSEND,DEST,I,K,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 I1, IA, JARR, ILOCROOT, JLOCROOT INTEGER IS1, ISHIFT, IIW, IS, IAS INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 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_330( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE = MUMPS_275( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_810( PROCNODE_STEPS(ISTEP), & SLAVEF ) I_AM_CAND_LOC = .FALSE. 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 = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL END IF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 ) & .AND. IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF (MUMPS_275( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) == MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL SMUMPS_310( 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 DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) & CALL SMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN CALL SMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN CALL SMUMPS_34( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( DEST .GT. 0 ) THEN CALL SMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) IF ( T4MASTER.GT.0 ) THEN CALL SMUMPS_34( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN CALL SMUMPS_34( 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_18( & 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_148 SUBROUTINE SMUMPS_34(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_34 SUBROUTINE SMUMPS_18( & 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_18 RECURSIVE SUBROUTINE SMUMPS_310( 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_310(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL SMUMPS_310(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE SMUMPS_310 SUBROUTINE SMUMPS_145( 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, LDBLARR, LINTARR, & COMM INTEGER INTARR(LINTARR) INTEGER 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) 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, IA, I1, I, allocok INTEGER IS, IS1, ISHIFT, IIW, IAS INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 REAL VAL REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR 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 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 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_330( 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 IA = PTRARW(IARR) DBLARR(IA) = DBLARR(IA) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL ENDIF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) & .AND. IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_275( 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_310( 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_145 SUBROUTINE SMUMPS_266( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & TNBPROCFILS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, ITLOC, RHS_MUMPS, & IFLAG, IERROR ) USE SMUMPS_LOAD IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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 COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_RECU, NFRONT INTEGER LREQ INTEGER(8) :: LREQCB DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' INODE = BUFR( 1 ) NBPROCFILS = BUFR( 2 ) NROW = BUFR( 3 ) NCOL = BUFR( 4 ) NASS = BUFR( 5 ) NFRONT = BUFR( 6 ) NSLAVES_RECU = BUFR( 7 ) 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_190(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_22(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP,KEEP8, 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 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( 8 + NSLAVES_RECU : 7 + NSLAVES_RECU + NROW + NCOL ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_RECU.GT.0) & IW( IWPOSCB + 7+XTRA_SLAVES_UNSYM+KEEP(IXSZ): & IWPOSCB+6+KEEP(IXSZ)+NSLAVES_RECU ) = & BUFR( 8: 7 + NSLAVES_RECU ) ELSE IW( IWPOSCB + 7+KEEP(IXSZ) ) = 0 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( 8: 7 + NSLAVES_RECU ) END IF TNBPROCFILS(STEP( INODE )) = NBPROCFILS RETURN END SUBROUTINE SMUMPS_266 SUBROUTINE SMUMPS_163( id ) USE SMUMPS_STRUC_DEF USE SMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC) id INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) PAR_loc=id%PAR SYM_loc=id%SYM CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( PAR_loc .eq. 0 ) THEN 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 CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF CALL SMUMPS_20( 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%WRITE_PROBLEM="NAME_NOT_INITIALIZED" CALL MUMPS_SET_VERSION( id%VERSION_NUMBER ) id%OOC_TMPDIR="NAME_NOT_INITIALIZED" id%OOC_PREFIX="NAME_NOT_INITIALIZED" id%NRHS = 1 id%LRHS = 0 id%LREDRHS = 0 CALL SMUMPS_61( id%KEEP( 34 ), id%KEEP(35) ) NULLIFY(id%BUFR) id%MAXIS1 = 0 id%INST_Number = -1 id%N = 0; id%NZ = 0 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0 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) 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%POIDS) 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%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) 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%CB_SON_SIZE) 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) id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 id%SCHUR_NLOC = 0 id%SCHUR_LLD = 0 NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) CALL SMUMPS_637(id) NULLIFY(id%MEM_DIST) NULLIFY(id%SUP_PROC) id%Deficiency = 0 id%root%LPIV = -1 id%root%yes = .FALSE. id%root%gridinit_done = .FALSE. 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_163 SUBROUTINE SMUMPS_252( COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & & 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 & ) USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR 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) INTEGER IFLAG,IERROR,INODE,MAXFRW, & IWPOS, IWPOSCB, COMP INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 REAL A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)) INTEGER NSTK_S(KEEP(28)),PROCNODE_STEPS(KEEP(28)) INTEGER IPOOL( LPOOL ) INTEGER BUFR( LBUFR ) INTEGER IDUMMY(1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(N), PTRAIW(N), ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 INTARR(max(1,KEEP(14))) REAL DBLARR(max(1,KEEP(13))) INTEGER MUMPS_330 EXTERNAL MUMPS_330 INTEGER LP, HS, HF 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) :: SIZFR INTEGER SIZFI, NCB INTEGER J1,J2 INTEGER NCOLS, NROWS, LDA_SON INTEGER(8) :: JJ2, ICT13 #if defined(ALLOW_NON_INIT) INTEGER(8) :: NUMROWS, JJ3, JJ8, APOS_ini #endif INTEGER NELIM,JJ,JJ1,J3, & IBROT,IORG INTEGER JPOS,ICT11 INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4 INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER AINPUT 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 INCLUDE 'mumps_headers.h' INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_167 LOGICAL MUMPS_167 LOGICAL SSARBR LOGICAL COMPRESSCB INTEGER(8) :: LCB DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_170 LOGICAL MUMPS_170 COMPRESSCB =.FALSE. NELT = 1 LPTRAR = N NFS4FATHER = -1 IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (LEVEL.NE.1) THEN write(6,*) 'Error1 in mpi51f_niv1 ' CALL MUMPS_ABORT() ENDIF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_167(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) ENDDO 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 NASS = NASS + IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG LREQ_OOC = 0 IF (KEEP(201).EQ.1) THEN CALL SMUMPS_684( 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF 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_330(PROCNODE_STEPS(STEP(ISON)),SLAVEF) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_729(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. IF (KEEP(50).EQ.0 .AND. KEEP(234) .EQ. 0) THEN CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, & NFRONT_EFF, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, & PROCNODE_STEPS, SLAVEF ) ELSE CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF) IF (IFLAG.LT.0) GOTO 300 ENDIF IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_170(PROCNODE_STEPS(STEP(INODE)), & SLAVEF))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL SMUMPS_190(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 Write(*,*) ' ERROR 1 during ass_niv1', NFRONT, NFRONT_EFF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL SMUMPS_691(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 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 GOTO 280 ELSE CALL SMUMPS_94 & (N, KEEP(28), IW, LIW, A, LA, LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER,KEEP(216),LRLUS,KEEP(IXSZ)) COMP = COMP + 1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL SMUMPS_471(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLU) #if ! defined(ALLOW_NON_INIT) 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) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO ELSE IF (ETATASS.EQ.1) THEN APOS_ini = POSELT DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8,int(NASS1-1,8)) APOS = APOS_ini + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO ELSE APOS_ini = POSELT NUMROWS = min(NFRONT8, (IPTRLU-APOS_ini) / NFRONT8 ) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = APOS_ini + JJ8 * NFRONT8 A(APOS:APOS + JJ8) = ZERO ENDDO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = APOS_ini + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST_S(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 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)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) 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.LE.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS J1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1) THEN J2 = J1 + LSTK - 1 SIZFR = int(LSTK,8)*int(LSTK,8) IF (COMPRESSCB) SIZFR = (int(LSTK,8)*int(LSTK+1,8))/2_8 ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR = int(NELIM,8) * int(LSTK,8) ELSE SIZFR = int(NELIM,8) * int(NELIM,8) END IF J2 = J1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) OPASSW = OPASSW + dble(SIZFR) 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 + SIZFR - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (J2.GE.J1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC) RISK_OF_SAME_POS = IACHK + SIZFR - 1_8 .EQ. POSFAC - 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. & ((J2-J1).GT.300) DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * int(NFRONT,8) IACHK = IACHK_ini + int(JJ-J1,8)*int(LSTK,8) IF (RISK_OF_SAME_POS) THEN IF (JJ.EQ.J2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(IW(J1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(JJ>J1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) IF ( IACHK+int(JJ1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(JJ1 - 1,8)) A(IACHK + int(JJ1 -1,8)) = ZERO ENDIF ENDDO ELSE DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 A(JJ2) = A(IACHK + int(JJ1 - 1,8)) A(IACHK + int(JJ1 -1,8)) = ZERO ENDDO ENDIF ELSE DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 1,8)) ENDDO ENDIF 170 CONTINUE END IF ELSE IF (LEVEL1) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR ELSE LCB = int(LDA_SON,8)* int(J2-J1+1,8) ENDIF CALL SMUMPS_178(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), J2 - J1 + 1, NELIM, ETATASS, & COMPRESSCB, (ISON.EQ.ISON_IN_PLACE) & ) 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 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 J3 = J3 - 1 DO JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = 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_152(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_49( & 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_210( 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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .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_71( & 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_329( & 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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 JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) IJROW = INTARR(J1) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) Cduplicates --> CVD$ DEPCHK DO 240 JJ = J1, J2 APOS2 = ICT12 + int(INTARR(JJ),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + 1 240 CONTINUE IF (J3 .LE. J4) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = J4 - J3 + 1 Cduplicates--> CVD$ DEPCHK CduplicatesCVD$ NODEPCHK DO 250 JJ = 1, NBCOL APOS3 = ICT13 + int(INTARR(J3 + JJ - 1) - 1,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT + JJ - 1) 250 CONTINUE ENDIF IF (KEEP(50).EQ.0) THEN DO JJ=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ELSE DO JJ=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+JJ-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE GOTO 500 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_252' ENDIF GOTO 490 280 CONTINUE IFLAG = -9 CALL MUMPS_731(LAELL_REQ8 - LRLUS, IERROR) IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING SMUMPS_252' ENDIF 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 DURING SMUMPS_252' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING SMUMPS_252' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING SMUMPS_252' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 490 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_252 SUBROUTINE SMUMPS_253(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM , MEM_DISTRIB) USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER IFLAG,IERROR,INODE,MAXFRW, & LPOOL, LEAF, IWPOS, IWPOSCB, COMP INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC REAL A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, SLAVEF, 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 IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(N), PTRAIW(N), ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 INTARR(max(1,KEEP(14))) REAL DBLARR(max(1,KEEP(13))) INTEGER LP, HS, HF, HF_OLD,NCBSON, NSLAVES_OLD, & NBSPLIT INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER,I INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER NCB INTEGER J1,J2,J3,MP INTEGER(8) :: JJ8, LAPOS2, JJ2, JJ3 INTEGER NELIM,JJ,JJ1,NPIVS,NCOLS,NROWS, & IBROT,IORG INTEGER LDAFS, LDA_SON INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4, NUMORG_SPLIT INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 INTEGER AINPUT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, ISLAVE, PDEST INTEGER PDEST1(1) INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6 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_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 REAL ZERO REAL RZERO PARAMETER(RZERO = 0.0E0 ) PARAMETER( ZERO = 0.0E0 ) INTEGER NELT, LPTRAR, NCBSON_MAX logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER (8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok, & NCB_SPLIT, SIZE_LIST_SPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER NBPANELS_L, NBPANELS_U MP = ICNTL(2) 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_330(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) .EQ. 1) THEN NCBSON_MAX = max & ( & IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)), NCBSON_MAX & ) 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 IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) SIZE_TMP_SLAVES_LIST = CAND( SLAVEF+1, INIV2 ) ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), & SLAVEF) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) 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 265 ENDIF CALL SMUMPS_791 ( & 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_472( 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_790 ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) TMP_SLAVES_LIST (1:SIZE_TMP_SLAVES_LIST) & = CAND (1:SIZE_TMP_SLAVES_LIST, INIV2) CALL SMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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_472( 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_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. IF (KEEP(50).EQ.0 .AND. KEEP(234).EQ.0) THEN CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, & NFRONT_EFF, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & PROCNODE_STEPS, SLAVEF ) ELSE ISON_IN_PLACE = -9999 CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF) IF (IFLAG.LT.0) GOTO 250 ENDIF 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 plitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF 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 WRITE(6,*) ' Internal error 2 in fac_ass due', & ' to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF CALL MUMPS_ABORT() ELSE CALL SMUMPS_472( 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 JJ=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+JJ)=IW(IOLDPS+HF_OLD+JJ) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO JJ=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+JJ) = IW(IOLDPS+HF_OLD+JJ) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE Write(*,*) MYID,': ERROR 2 during ass_niv2, INODE=', INODE, & ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL SMUMPS_691(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST_S(STEP(INODE)) = IOLDPS 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+KEEP(IXSZ)) = NFRONT 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_461(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_533(SLAVEF,CAND(SLAVEF+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_533(SLAVEF,SLAVEF-1, & 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 CALL SMUMPS_471(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLU) POSEL1 = POSELT - int(LDAFS,8) #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, int(LDAFS-1,8) A(APOS:APOS+JJ8) = ZERO APOS = APOS + int(LDAFS,8) END DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN A(APOS:APOS+int(LDAFS,8)-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 + 1+KEEP(IXSZ)) 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.LE.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 + 2+KEEP(IXSZ)) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) J1 = ISTCHK + HS + NROWS + NPIVS J2 = J1 + 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 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * int(LDAFS,8) DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 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 CALL SMUMPS_178( A, LA, & POSELT, LDAFS, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), NELIM, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) DO 260 IORG = 1, NUMORG JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) IJROW = INTARR(J1) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO CduplicatesCVD$ NODEPCHK DO 240 JJ = J1, J2 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT))) ENDIF ELSE IF (INTARR(JJ).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) ENDIF ENDIF AINPUT = AINPUT + 1 240 CONTINUE IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = MAXARR ENDIF IF (J3 .GT. J4) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = J4 - J3 + 1 CduplicatesCVD$ NODEPCHK CduplicatesCVD$ NODEPCHK DO JJ = 1, NBCOL JJ3 = ICT13 + int(INTARR(J3 + JJ - 1),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT + JJ - 1) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO JJ = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & 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_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & IW(PDEST), NFRONT, COMM, IERR) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL SMUMPS_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & IW(PDEST), NFRONT, COMM, IERR) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST_S(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 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.LE.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) THEN IF(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 ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) IF (PDEST1(1).EQ.MYID) THEN CALL SMUMPS_211( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON))+HS+NROWS+NPIVS+NELIM CALL SMUMPS_71( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST_S(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_329( 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, ND, FRERE, LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_49( & 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_210( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .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_71( & INODE, NFRONT,NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST_S(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_329( 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & SMUMPS_253' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 GOTO 490 265 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING SMUMPS_253' ENDIF IFLAG = -13 IERROR = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_253' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING SMUMPS_253' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8-LRLUS, IERROR) 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_253' ENDIF IFLAG = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) 490 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_253 SUBROUTINE SMUMPS_39(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_39 SUBROUTINE SMUMPS_539 & (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), PTRARW(N), PTRAIW(N) REAL :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) REAL A(LA), & DBLARR(max(1,KEEP(13))) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSELT, ICT12, APOS INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS,JJ, & IN,AINPUT,JK,J1,J2,IJROW, ILOC INTEGER :: K1RHS, K2RHS, JFirstRHS 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 A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = & ZERO 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) AINPUT = PTRARW(IN) JK = PTRAIW(IN) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) IJROW = -ITLOC(INTARR(J1)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ= J1,J2 ILOC = ITLOC(INTARR(JJ)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT) ENDIF AINPUT = AINPUT + 1 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO 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_539 SUBROUTINE SMUMPS_531 & (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_531 SUBROUTINE SMUMPS_40(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 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 write(6,*) ' .. exit for col =', J 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_40 SUBROUTINE SMUMPS_178( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED, IS_INPLACE & ) 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, IS_INPLACE REAL ZERO PARAMETER( ZERO = 0.0E0 ) LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE, OMP_FLAG INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IF ( IS_INPLACE ) THEN 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 ENDIF 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN OMP_FLAG = (NROWS-NELIM).GE.300 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) .AND. .NOT. IS_INPLACE) 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) + & A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 END DO ENDIF END 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_178 SUBROUTINE SMUMPS_530(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_530 SUBROUTINE SMUMPS_619( & 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(abs(A(JJ2)) .LT. VALSON(JJ1)) & A(JJ2) = VALSON(JJ1) ENDDO RETURN END SUBROUTINE SMUMPS_619 RECURSIVE SUBROUTINE SMUMPS_264( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE SMUMPS_OOC USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mumps_headers.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 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 PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 REAL DBLARR(max(1,KEEP(13))) 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 ) INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL INTEGER(8) :: POSBLOCFACTO 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 MUMPS_275 EXTERNAL MUMPS_275 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 ) LAELL = int(NPIV,8) * int(NCOL,8) IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_731(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_264" ENDIF GOTO 700 END IF CALL SMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731( 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_264" 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)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL SMUMPS_471(.FALSE., .FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, & MPI_REAL, & COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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)) 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 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 LPOS2 = POSELT + int(NPIV1,8) CALL strsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), NCOL, A(LPOS2), NCOL1) LPOS1 = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) ENDIF 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 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL SMUMPS_688( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( NPIV .GT. 0 ) THEN CALL sgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,A(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 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. LASTBL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) ' ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) IWPOS = IWPOS - NPIV 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_190( 1, .FALSE., FLOP1, KEEP,KEEP8 ) IF (LASTBL) THEN CALL SMUMPS_759( & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE SMUMPS_264 SUBROUTINE SMUMPS_699( 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_S, 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, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE SMUMPS_LOAD USE SMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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_S( KEEP(28) ) INTEGER NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) REAL A( LA ) 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( max(1,KEEP(14)) ) REAL DBLARR( max( 1,KEEP(13)) ) 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 STATUS( MPI_STATUS_SIZE ) INTEGER MUMPS_275, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_810 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 BLOCKING, SET_IRECV, MESSAGE_RECEIVED, IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT 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_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_810(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) DO WHILE ( PTRIST( STEP(INODE) ) .EQ. 0 ) MASTER = MUMPS_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MASTER, MAITRE_DESC_BANDE, & STATUS, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF (IFLAG.LT.0) RETURN END DO 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_731( LREQA - LRLUS, IERROR ) CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF CALL SMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..process_contrib' WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 CALL MUMPS_731( LREQA - LRLUS, IERROR ) CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF END IF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) 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))-1 ENDIF IF ( KEEP(55) .eq. 0 ) THEN CALL SMUMPS_539 & (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_123( & 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_40(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_531 & (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_39(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST_S, 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_617(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_REAL, & COMM, IERR ) CALL SMUMPS_619(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - 1 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK .LT. IWPOSCB IF (SAME_PROC) THEN CALL SMUMPS_530(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, 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_152(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN CALL SMUMPS_507( 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_500( & 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 POSFAC = POSFAC - LREQA CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) RETURN END SUBROUTINE SMUMPS_699 SUBROUTINE SMUMPS_143( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, UU, NOFFW, & NPVW, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS ) USE SMUMPS_OOC IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, 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(30) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK INTEGER NASS, NEL1, NPIVB, NPIVE, NBOLKJ, NBTLKJ REAL UUTEMP INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INCLUDE 'mumps_headers.h' EXTERNAL MUMPS_330, SMUMPS_221, SMUMPS_233, & SMUMPS_229, & SMUMPS_225, SMUMPS_232, SMUMPS_231, & SMUMPS_220, & SMUMPS_228, SMUMPS_236 INTEGER MUMPS_330 LOGICAL STATICMODE REAL SEUIL_LOC 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 IBEG_BLOCK=1 NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IF (KEEP(201).EQ.1) THEN CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_BOTH_LU 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 50 CONTINUE CALL SMUMPS_221(NFRONT,NASS,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) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF GOTO 80 ENDIF IF (INOPV.EQ.2) THEN CALL SMUMPS_233(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP(IXSZ)) GOTO 50 ENDIF NPVW = NPVW + 1 IF (NASS.LE.1) THEN CALL SMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 GO TO 500 ENDIF CALL SMUMPS_225(IBEG_BLOCK,NFRONT, NASS, N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 50 IF (KEEP(201).EQ.1) THEN MonBloc%LastPiv= IW(IOLDPS+1+KEEP(IXSZ)) STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_U LAST_CALL = .FALSE. CALL SMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC ENDIF IF (IFINB.EQ.(-1)) GOTO 80 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV CALL SMUMPS_232(A,LA, & NFRONT,NPIV,NASS,POSELT,NBTLKJ) GO TO 50 80 CONTINUE NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IF (NPIV.LE.0) GO TO 110 NEL1 = NFRONT - NASS IF (NEL1.LE.0) GO TO 110 IF (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_BOTH_LU MonBloc%LastPiv= NPIV CALL SMUMPS_642(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_231(A,LA,NFRONT, NPIV,NASS,POSELT) ENDIF 110 CONTINUE IF (MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) & .EQ.1) THEN NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 120 CALL SMUMPS_220(NFRONT,NASS,N,INODE,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) IF (INOPV.NE.1) THEN NPVW = NPVW + 1 CALL SMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVB = IBEG_BLOCK NPIVE = NPIV - NPIVB NEL1 = NFRONT - NASS IF ((NPIVE.LE.0).OR.(NEL1.EQ.0)) GO TO 500 CALL SMUMPS_236(A,LA,NPIVB, & NFRONT,NPIV,NASS,POSELT) ENDIF 500 CONTINUE IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) TYPEFile = TYPEF_BOTH_LU LAST_CALL = .TRUE. CALL SMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC CALL SMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE SMUMPS_143 RECURSIVE SUBROUTINE SMUMPS_322( & 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) 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) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(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 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 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( max(1,KEEP(14)) ) REAL DBLARR( max(1,KEEP(13)) ) INTEGER INIV2, ISHIFT, IBEG INTEGER MUMPS_275 EXTERNAL MUMPS_275 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 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) CHARACTER(LEN=35)::SUBNAME MP = ICNTL(2) LP = ICNTL(1) SUBNAME="??????" CALL SMUMPS_467(COMM_LOAD, KEEP) 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_269( MYID,KEEP,KEEP8, & 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_269" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL SMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL SMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_500( & 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_266( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, NBPROCFILS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, ITLOC, RHS_MUMPS, & IFLAG, IERROR ) SUBNAME="SMUMPS_266" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL SMUMPS_268(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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & KEEP,KEEP8, ND, FILS, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="SMUMPS_268" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO ) THEN CALL SMUMPS_264( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL SMUMPS_263( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL SMUMPS_274( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL SMUMPS_699( 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_S, 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, IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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).AND.(KEEP(48).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_210( 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_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL SMUMPS_700( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF) SUBNAME="SMUMPS_700" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(IROOT)), & SLAVEF ) IF ( PTLUST_S( STEP(IROOT)) .EQ. 0 ) THEN CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL SMUMPS_270( TMP( 1 ), TMP( 2 ), & 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, ND ) SUBNAME="SMUMPS_270" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL SMUMPS_700( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF ) SUBNAME="SMUMPS_700" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL SMUMPS_271( 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GO TO 100 IF (MYID.NE.MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF)) THEN IF (KEEP(50).EQ.0) THEN IF (IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)) = S_ROOT2SON_CALLED ELSE CALL SMUMPS_626( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ELSE IF (IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)) = S_ROOT2SON_CALLED ELSE CALL SMUMPS_626( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL SMUMPS_270( 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_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, 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_273( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, KEEP,KEEP8, & COMM, COMM_LOAD, FILS, ND) SUBNAME="SMUMPS_273" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in SMUMPS_322" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine SMUMPS_322.',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_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE SMUMPS_322 RECURSIVE SUBROUTINE SMUMPS_280( & COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) 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) 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(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(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 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 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( max(1,KEEP(14)) ) REAL DBLARR( max(1,KEEP(13)) ) 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_44( MYID, SLAVEF, COMM ) RETURN ENDIF CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL SMUMPS_322( & 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) RETURN END SUBROUTINE SMUMPS_280 RECURSIVE SUBROUTINE SMUMPS_329( & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED ) 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) 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(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 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 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( max(1,KEEP(14)) ) REAL DBLARR( max(1,KEEP(13)) ) 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_467(COMM_LOAD, KEEP) 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 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_329' CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF IF ( FLAG ) THEN 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_322( 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_280( COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_280( COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_329 SUBROUTINE SMUMPS_255( INFO1, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE SMUMPS_COMM_BUFFER 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 STATUS( MPI_STATUS_SIZE ) LOGICAL NO_ACTIVE_IRECV INTEGER MSGSOU_LOC, MSGTAG_LOC 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) ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL SMUMPS_62 & (DUMMY, DEST, TAG_DUMMY, COMM, 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 RETURN END SUBROUTINE SMUMPS_255 SUBROUTINE SMUMPS_180( & INFO1, BUFR, LBUFR, LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, MP ) USE SMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER COMM_NODES, COMM_LOAD, SLAVEF, INFO1, MP INTEGER STATUS( MPI_STATUS_SIZE ) LOGICAL FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS INTEGER MSGSOU_LOC, MSGTAG_LOC, COMM_EFF INTEGER IERR INTEGER IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS IF (SLAVEF.EQ.1) RETURN BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. 10 CONTINUE FLAG = .TRUE. DO WHILE ( FLAG ) COMM_EFF = COMM_NODES CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, & COMM_NODES, FLAG, STATUS, IERR) IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_LOAD CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM_LOAD, FLAG, STATUS, IERR) END IF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_RECV( BUFR, LBUFR_BYTES, & MPI_PACKED, MSGSOU_LOC, & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) ENDIF END DO IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN RETURN ENDIF CALL SMUMPS_469(BUFFERS_EMPTY) IF ( BUFFERS_EMPTY ) THEN IBUF_EMPTY = 0 ELSE IBUF_EMPTY = 1 ENDIF CALL MPI_ALLREDUCE(IBUF_EMPTY, & IBUF_EMPTY_ON_ALL_PROCS, & 1, MPI_INTEGER, MPI_MAX, & COMM_NODES, IERR) IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. ELSE BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. ENDIF GOTO 10 END SUBROUTINE SMUMPS_180 INTEGER FUNCTION SMUMPS_748 & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) K227_LOC = abs(K227) IF (K50.EQ.2) THEN K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) ELSE 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_748 = EFFECTIVE_SIZE RETURN END FUNCTION SMUMPS_748 SUBROUTINE SMUMPS_698( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) REAL THE_PANEL(NBROW, NBCOL) INTEGER I, IPERM DO I = 1, LPIV 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_698 SUBROUTINE SMUMPS_667(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) INTEGER I_NBPANELS, I_NASS I_NASS = IPOS I_NBPANELS = I_NASS + 1 NBPANELS = IW(I_NBPANELS) I_PIVPTR = I_NBPANELS + 1 I_PIV = I_PIVPTR + NBPANELS IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) NBPANELS = IW(I_NBPANELS) I_PIVPTR = I_NBPANELS + 1 I_PIV = I_PIVPTR + NBPANELS ENDIF RETURN END SUBROUTINE SMUMPS_667 SUBROUTINE SMUMPS_691(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) INTEGER IPOS_U IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: SMUMPS_691 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_691 SUBROUTINE SMUMPS_644 ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE SMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE IF (KEEP(50).EQ.1) RETURN IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE CALL SMUMPS_667(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 CALL SMUMPS_667(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 IF (FREESPACE) THEN IW(IBEGOOC) = -7777 IW(IOLDPS+XXI) = IBEGOOC - IOLDPS + 1 IWPOS = IBEGOOC+1 ENDIF RETURN END SUBROUTINE SMUMPS_644 SUBROUTINE SMUMPS_684(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE SMUMPS_OOC IMPLICIT NONE INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF NBPANELS_L = (NASS / SMUMPS_690(NBROW_L))+1 LREQ = 1 & + 1 & + NASS & + NBPANELS_L IF (K50.eq.0) THEN NBPANELS_U = (NASS / SMUMPS_690(NBCOL_U) ) +1 LREQ = LREQ + 1 & + NASS & + NBPANELS_U ENDIF RETURN END SUBROUTINE SMUMPS_684 SUBROUTINE SMUMPS_755 & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_755 mumps-4.10.0.dfsg/src/mumps_c.c0000644000175300017530000004515511562233011016503 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ /* Written by JYL, march 2002 */ /* This file groups so far all C functions and symbols that vary with the arithmetic */ /* 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 *nz, 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_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 ); #ifdef return_scaling /* * Those two are static. They are passed inside cmumps_f77 but * might also be changed on return by MUMPS_AFFECT_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 SMUMPS_COLSCA_STATIC # define MUMPS_ROWSCA_STATIC SMUMPS_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_AFFECT_COLSCA \ F_SYM_ARITH(affect_colsca,AFFECT_COLSCA) void MUMPS_CALL MUMPS_AFFECT_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_AFFECT_ROWSCA \ F_SYM_ARITH(affect_rowsca,AFFECT_ROWSCA) void MUMPS_CALL MUMPS_AFFECT_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; } #endif /* return_scaling */ #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 *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 */ int ooc_tmpdirlen; int ooc_prefixlen; int write_problemlen; int i; static const MUMPS_INT no = 0; static const MUMPS_INT yes = 1; idummyp = &idummy; cdummyp = &cdummy; rdummyp = &rdummy; #ifdef return_scaling /* Don't forget to initialize those two before * each call to mumps as we may copy values from * old instances otherwise ! */ MUMPS_COLSCA_STATIC=0; MUMPS_ROWSCA_STATIC=0; #endif /* 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->rowsca=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->nz_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(colsca,rdummyp); EXTRACT_POINTERS(rowsca,rdummyp); 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; 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, &(mumps_par->nz), irn, &irn_avail, jcn, &jcn_avail, a, &a_avail, &(mumps_par->nz_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 ); /* * mapping and pivnul_list are usually 0 except if * MUMPS_AFFECT_MAPPING/MUMPS_AFFECT_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(); #ifdef return_scaling /* * colsca/rowsca can either be user data or have been * modified within mumps by calls to MUMPS_AFFECT_COLSCA/ROWSCA. */ if (colsca_avail == no) mumps_par->colsca = MUMPS_COLSCA_STATIC; if (rowsca_avail == no) mumps_par->rowsca = MUMPS_ROWSCA_STATIC; #endif } mumps-4.10.0.dfsg/src/mumps_orderings.c0000644000175300017530000003116111562233011020245 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ /* * This file contains interfaces to external ordering packages. * At the moment, PORD (J. Schulze) and SCOTCH are interfaced. */ #include "mumps_orderings.h" #if defined(pord) /* Interface to PORD */ /*int mumps_pord( int, int, int *, int *, int * ); #define MUMPS_PORDF \ F_SYMBOL(pordf,PORDF)*/ void MUMPS_CALL MUMPS_PORDF( int *nvtx, int *nedges, int *xadj, int *adjncy, int *nv, int *ncmpa ) { *ncmpa = mumps_pord( *nvtx, *nedges, xadj, adjncy, nv ); } /* Interface to PORD with weighted graph*/ /*int mumps_pord_wnd( int, int, int *, int *, int *, int * ); #define MUMPS_PORDF_WND \ F_SYMBOL(pordf_wnd,PORDF_WND)*/ void MUMPS_CALL MUMPS_PORDF_WND( int *nvtx, int *nedges, int *xadj, int *adjncy, int *nv, int *ncmpa, int *totw ) { *ncmpa = mumps_pord_wnd( *nvtx, *nedges, xadj, adjncy, nv, totw ); } /************************************************************ mumps_pord is used in ana_aux.F permutation and inverse permutation not set in 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 ******************************************************************/ /*********************************************************/ int mumps_pord ( int nvtx, int nedges, int *xadj_pe, int *adjncy, int *nv ) { /********************************** Argument Comments: input: ----- - nvtx : dimension of the Problem (N) - nedges : number of entries (NZ) - adjncy : non-zeros entries (IW input) input/output: ------------- - xadj_pe : pointer through beginning of column non-zeros entries (PTRAR) - on exit, "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 }; int *ncolfactor, *ncolupdate, *parent, *vtx2front; int *first, *link, nfronts, J, K, u, vertex, vertex_root, count; /************************************************** declaration to uncomment if printing ordering *************************************************** FILE *fp1, *fp2; int *perm, *iperm; */ /*** decalage des indices couteux dans un premier temps: **** A modifier dans une version ulterieure de MA41GD */ 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; mymalloc(G->vwght, nvtx, int); G->nvtx = nvtx; G->nedges = nedges; 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, int); mymalloc(link, nvtx, 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) { /* JY: I think this cannot happen */ printf(" Internal error in mumps_pord (cf JY), %d\n",K); 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); } /*********************************************************/ int mumps_pord_wnd ( int nvtx, int nedges, int *xadj_pe, int *adjncy, int *nv, int *totw ) { /********************************** Argument Comments: 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 : pointer through beginning of column non-zeros entries (PTRAR) - on exit, "father array" (PE) ouput: ------ - nv : weight of the vertices - on exit "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 }; int *ncolfactor, *ncolupdate, *parent, *vtx2front; int *first, *link, nfronts, J, K, u, vertex, vertex_root, count; /************************************************** declaration to uncomment if printing ordering *************************************************** FILE *fp1, *fp2; int *perm, *iperm; */ /*** decalage des indices couteux dans un premier temps: **** A modifier dans une version ulterieure de MA41GD */ 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; mymalloc(G->vwght, nvtx, int); G->nvtx = nvtx; G->nedges = nedges; G->type = WEIGHTED; G->totvwght = (*totw); 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, int); mymalloc(link, nvtx, 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) { /* JY: I think this cannot happen */ printf(" Internal error in mumps_pord (cf JY), %d\n",K); 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 */ /************************************************************/ #if defined(scotch) || defined(ptscotch) /*int esmumps( const int n, const int iwlen, int * const pe, const int pfree, int * const len, int * const iw, int * const nv, int * const elen, int * const last);*/ /* Fortran interface to SCOTCH */ /*#define MUMPS_SCOTCH \ F_SYMBOL(scotch,SCOTCH)*/ void MUMPS_CALL MUMPS_SCOTCH( const int * const n, const int * const iwlen, int * const petab, const int * const pfree, int * const lentab, int * const iwtab, int * const nvtab, int * const elentab, int * const lasttab, int * const ncmpa ) { *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); } #endif /* scotch */ #if defined(ptscotch) /*#include "mpi.h" #include #include "ptscotch.h" int mumps_dgraphinit( SCOTCH_Dgraph *, MPI_Fint *, MPI_Fint *); #define MUMPS_DGRAPHINIT \ F_SYMBOL(dgraphinit,DGRAPHINIT)*/ 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 #if defined(parmetis) void MUMPS_CALL MUMPS_PARMETIS(int *first, int *vertloctab, int *edgeloctab, int *numflag, int *options, int *order, int *sizes, int *comm) { MPI_Comm int_comm; int_comm = MPI_Comm_f2c(*comm); ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); return; } #endif mumps-4.10.0.dfsg/src/cmumps_part6.F0000644000175300017530000046503611562233067017442 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE CMUMPS_324(A, LDA, NPIV, NBROW, K50 ) IMPLICIT NONE INTEGER LDA, NPIV, NBROW, K50 COMPLEX A(int(LDA,8)*int(NBROW+NPIV,8)) 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_324 SUBROUTINE CMUMPS_651(A, LDA, NPIV, NCONTIG ) IMPLICIT NONE INTEGER NCONTIG, NPIV, LDA COMPLEX A(NCONTIG*LDA) 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_651 SUBROUTINE CMUMPS_652( 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(ALLOW_NON_INIT) 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(ALLOW_NON_INIT) 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_652 SUBROUTINE CMUMPS_705( 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(ALLOW_NON_INIT) 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) 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(ALLOW_NON_INIT) IF (.NOT. COMPRESSCB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_705 SUBROUTINE CMUMPS_140( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, & UU, NNEG, NPVW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS ) USE CMUMPS_OOC IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, 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(30) INTEGER INOPV, IFINB, NFRONT, NPIV, NBOLKJ, & NBTLKJ,IBEG_BLOCK INTEGER NASS, NEL1, IFLAG_OOC INTEGER :: LDA REAL UUTEMP INCLUDE 'mumps_headers.h' EXTERNAL CMUMPS_222, CMUMPS_234, & CMUMPS_230, CMUMPS_226, & CMUMPS_237 LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVSIZ,IWPOSP2 INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY LOGICAL POSTPONE_COL_UPDATE, IS_MAXFROMM_AVAIL REAL MAXFROMM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L INTEGER PP_LastPIVRPTRFilled IS_MAXFROMM_AVAIL = .FALSE. 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 POSTPONE_COL_UPDATE = (UUTEMP == 0.0E0 .AND. KEEP(201).NE.1) IBEG_BLOCK = 1 NFRONT = IW(IOLDPS+KEEP(IXSZ)) LDA = NFRONT NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IF (KEEP(201).EQ.1) THEN IDUMMY = -8765 CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L 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+KEEP(IXSZ): & IOLDPS+5+NFRONT+KEEP(IXSZ)+NFRONT) ENDIF IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) UUTEMP = UU 50 CONTINUE CALL CMUMPS_222(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & INOPV, NNEG, IFLAG,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, KEEP(IXSZ), & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL) 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+KEEP(IXSZ))+6+KEEP(IXSZ) & +IW(IOLDPS+5+KEEP(IXSZ)) PIVNUL_LIST(KEEP(109)) = IW(IWPOSP2) ENDIF ENDIF IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF CALL CMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, POSTPONE_COL_UPDATE, & ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG) GOTO 500 END IF IF (INOPV.EQ.2) THEN CALL CMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), & POSTPONE_COL_UPDATE, & KEEP,KEEP8) GOTO 50 ENDIF NPVW = NPVW + PIVSIZ IF (NASS.LE.1) THEN CALL CMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 GO TO 500 ENDIF CALL CMUMPS_226(IBEG_BLOCK, & NFRONT, NASS, N,INODE,IW,LIW,A,LA, & LDA, POSTPONE_COL_UPDATE, IOLDPS, & POSELT,IFINB, & NBTLKJ,PIVSIZ, KEEP(IXSZ),MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0E0), & KEEP(253) ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6 IW(IWPOSP2+NFRONT+KEEP(IXSZ)) = -IW(IWPOSP2+NFRONT+KEEP(IXSZ)) ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ IF (IFINB.EQ.0) GOTO 50 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV IF (KEEP(201).EQ.1) THEN IF (IFINB.EQ.-1) THEN MonBloc%Last = .TRUE. ELSE MonBloc%Last = .FALSE. ENDIF MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_688( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG .LT. 0 ) RETURN ENDIF CALL CMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), & POSTPONE_COL_UPDATE, & KEEP,KEEP8) IF (IFINB.EQ.-1) THEN CALL CMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG) & GOTO 500 ENDIF GO TO 50 500 CONTINUE IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) LAST_CALL=.TRUE. CALL CMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG < 0 ) RETURN CALL CMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE CMUMPS_140 SUBROUTINE CMUMPS_222 & (NFRONT,NASS,N,INODE,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) #if defined (PROFILE_BLAS_ASS_G) USE CMUMPS_LOAD #endif USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV, & IOLDPS, NNEG 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(30) 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 REAL RMAX,AMAX,TMAX,TOL REAL MAXPIV REAL PIVNUL COMPLEX FIXA, CSEUIL COMPLEX PIVOT,DETPIV PARAMETER(TOL = 1.0E-20) 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,NASSW,IPIV INTEGER NPIVP1,K 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) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL CMUMPS_667(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 NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL CMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO) THEN IF (abs(A(APOS)).EQ.RZERO) GO TO 630 IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF GO TO 420 ENDIF AMAX = RZERO JMAX = 0 IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM > PIVNUL .AND. abs(PIVOT) > TOL) THEN IF ( abs(PIVOT) .GT. max(UULOC*MAXFROMM,SEUIL) ) THEN IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, NASSW - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 IF ( (NFRONT - KEEP(253) - NASSW).GE.300 ) THEN OMP_FLAG = .TRUE. ELSE OMP_FLAG = .FALSE. ENDIF DO J=1, NFRONT - KEEP(253) - NASSW J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO 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, NASSW - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,NFRONT - NASSW A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN IF(SEUIL .GT. epsilon(SEUIL)) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL ENDIF PIVOT = A(POSPV1) KEEP(98) = KEEP(98)+1 GO TO 415 ENDIF ENDIF ENDIF IF (max(AMAX,abs(PIVOT)).LE.TOL) GO TO 460 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (AMAX.LE.TOL) GO TO 460 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 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 = (NFRONT-JMAX-KEEP(253). GE. 300) DO K = 1, NFRONT - JMAX - KEEP(253) JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 OMP_FLAG = (NFRONT-JMAX-KEEP(253). GE. 300) DO K = 1, NFRONT-JMAX-KEEP(253) JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO 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 ) GOTO 460 ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_762(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(103) = KEEP(103)+1 415 CONTINUE 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) THEN GOTO 416 ENDIF CALL CMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDA, NFRONT, 1, KEEP(219), KEEP(50), & KEEP(IXSZ)) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL CMUMPS_680( 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 (NASSW.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_222 SUBROUTINE CMUMPS_680( 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_680!" 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_680 SUBROUTINE CMUMPS_226(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW, & A,LA,LDA, POSTPONE_COL_UPDATE, & IOLDPS,POSELT,IFINB,LKJIB,PIVSIZ,XSIZE, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & KEEP253) IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB, & NPBEG, IBEG_BLOCK INTEGER LDA INTEGER(8) :: LA INTEGER(8) :: NFRONT8 COMPLEX A(LA) LOGICAL POSTPONE_COL_UPDATE INTEGER IW(LIW) COMPLEX VALPIV INTEGER(8) :: POSELT REAL, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, INTENT(in) :: KEEP253 REAL :: MAXFROMMTMP INTEGER IOLDPS, NCB1 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NPIV,JROW2 INTEGER NEL2,NEL INTEGER XSIZE COMPLEX ONE, ZERO 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 = IW(IOLDPS+1+XSIZE) NPIV_NEW = NPIV + PIVSIZ NEL = NFRONT - NPIV_NEW IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. JROW2 = IW(IOLDPS+3+XSIZE) NPBEG = IBEG_BLOCK NEL2 = JROW2 - NPIV_NEW IF (NEL2.EQ.0) THEN IF (JROW2.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) A(APOS) = VALPIV 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 (POSTPONE_COL_UPDATE) THEN NCB1 = NASS - JROW2 ELSE NCB1 = NFRONT - JROW2 ENDIF IF (.NOT. IS_MAX_USEFUL) THEN 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 ELSE MAXFROMMTMP=0.0E0 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 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 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) A(POSPV2) = A(POSPV1)/DETPIV A(POSPV1) = SWOP/DETPIV A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL ccopy(NFRONT-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL ccopy(NFRONT-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 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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 = JROW2+1,NFRONT K1 = JJ K2 = JJ+1_8 MULT1 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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_226 SUBROUTINE CMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT) IMPLICIT NONE INTEGER NFRONT,N,INODE,LIW INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) COMPLEX VALPIV INTEGER (8) :: APOS, POSELT, LPOS, NFRONT8 INTEGER IOLDPS,NEL INTEGER JROW COMPLEX, PARAMETER :: ONE = (1.0E0,0.0E0) APOS = POSELT VALPIV = ONE/A(APOS) A(APOS) = VALPIV NEL = NFRONT - 1 IF (NEL.EQ.0) GO TO 500 NFRONT8 = int(NFRONT,8) LPOS = APOS + NFRONT8 CALL CMUMPS_XSYR('U',NEL, -VALPIV, & A(LPOS), NFRONT, A(LPOS+1_8), NFRONT) DO JROW = 1,NEL A(LPOS) = VALPIV*A(LPOS) LPOS = LPOS + NFRONT8 END DO 500 CONTINUE RETURN END SUBROUTINE CMUMPS_230 SUBROUTINE CMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT, & POSTPONE_COL_UPDATE, & KEEP,KEEP8 ) IMPLICIT NONE INTEGER NFRONT, NASS,N,LIW, IBEG_BLOCK INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER(8) :: LDA8 INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1, NEL11 INTEGER LBP, HF INTEGER(8) :: LPOS,UPOS,APOS INTEGER LKJIT INTEGER LKJIBOLD, IROW INTEGER I, Block INTEGER BLSIZE LOGICAL POSTPONE_COL_UPDATE COMPLEX ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) LDA8 = int(LDA,8) LKJIBOLD = LKJIB NPIV = IW(IOLDPS+1+KEEP(IXSZ)) JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 NEL11 = NFRONT - NPIV IF ( LKJIW .NE. LKJIB ) THEN NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) LKJIB = min0(LKJIB, NASS - NPIV) ELSE LKJIB = NASS - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = NASS ENDIF IBEG_BLOCK = NPIV + 1 ELSEIF (JROW2.LT.NASS) THEN IBEG_BLOCK = NPIV + 1 IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) LKJIB = min0(LKJIB,NASS-NPIV) ENDIF IF (LKJIW.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF ( NASS - JROW2 > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NASS - JROW2 END IF IF ( NASS - JROW2 .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int(IROW - 1,8) APOS = POSELT + int(IROW - 1,8) * LDA8 + int(JROW2,8) CALL cgemm( 'N','N', IROW + Block - JROW2 - 1, Block, LKJIW, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ENDDO #else DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL cgemm( 'N','N', Block, NASS - IROW + 1, LKJIW, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF LPOS = POSELT + int(NASS,8)*LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG-1,8) * LDA8 + int(JROW2,8) APOS = POSELT + int(NASS,8)*LDA8 + int(JROW2,8) IF ( .NOT. POSTPONE_COL_UPDATE ) THEN CALL cgemm('N', 'N', NEL1, NFRONT-NASS, LKJIW, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) END IF ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_234 SUBROUTINE CMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, NASS, & LDA, NFRONT, LEVEL, K219, K50, XSIZE ) 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 ) INCLUDE 'mumps_headers.h' 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 CALL cswap( NPIVP1 - 1, & A( POSELT + int(NPIVP1-1,8) ), LDA, & A( POSELT + int(IPIV-1,8) ), LDA ) END IF CALL cswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL cswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP CALL cswap( NASS - IPIV, A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF ( LEVEL .eq. 1 ) THEN CALL cswap( NFRONT - NASS, & A( APOS + int(NASS-IPIV+1,8) * LDA8 ), LDA, & A( IDIAG + int(NASS-IPIV+1,8) * LDA8 ), LDA ) END IF 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_319 SUBROUTINE CMUMPS_237(NFRONT,NASS,N,INODE, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG & ) USE CMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,N,INODE,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 INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, I, IROWEND INTEGER I2, I2END, Block2 COMPLEX ONE, ALPHA, BETA, ZERO PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(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 DO I = 1, NPIV CALL ccopy( Block, A( LPOS+int(I-1,8) ), LDA, & A( UPOS+int(I-1,8)*LDA8 ), 1 ) CALL cscal( Block, A(POSELT+(LDA8+1_8)*int(I-1,8)), & A( LPOS + int(I - 1,8) ), LDA ) 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_688( & 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_237 SUBROUTINE CMUMPS_320( 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_327( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL CMUMPS_326( & 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_293( 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_281( 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_320 SUBROUTINE CMUMPS_293( 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_293 SUBROUTINE CMUMPS_281( 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_281 SUBROUTINE CMUMPS_327( 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_327 SUBROUTINE CMUMPS_326( 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_326 RECURSIVE SUBROUTINE CMUMPS_274( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD USE CMUMPS_OOC IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 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 PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX DBLARR( max(1,KEEP(13)) ) 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 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL 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 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 MUMPS_275 EXTERNAL MUMPS_275 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 FPERE = -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 ) LAELL = int(NPIV,8) * int(NCOL,8) 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_731(LAELL-LRLUS, IERROR) IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN CMUMPS_274, & REAL WORKSPACE TOO SMALL" GOTO 700 END IF CALL CMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731(LAELL-LRLUS,IERROR) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN CMUMPS_274, & INTEGER WORKSPACE TOO SMALL" IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL ENDIF KEEP8(67) = min(LRLUS, KEEP8(67)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) IF ( NPIV.GT.0 ) THEN IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, MPI_COMPLEX, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF DO WHILE ( NBPROCFILS(STEP(INODE)) .NE. 0 ) BLOCKING = .TRUE. SET_IRECV=.FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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)) 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 ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN CMUMPS_274" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF 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_274" 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 CALL ctrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), NCOL, & A(POSELT+int(NPIV1,8)), NCOL1 ) 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 LPOS = POSELT + int(NPIV1,8) DPOS = POSBLOCFACTO I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(IPIV+I-1) .GT. 0) THEN CALL cscal( NROW1, A(DPOS), A(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(NCOL + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(NCOL + 1,8) OFFDAG = POSPV1+1_8 LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A(POSPV1)*A(LPOS1)+A(OFFDAG)*A(LPOS1+1_8) MULT2 = A(OFFDAG)*A(LPOS1)+A(POSPV2)*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(NCOL + 1,8) I = I+2 ENDIF ENDDO ENDIF 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 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL CMUMPS_688( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN 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 FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * NCOL - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL CMUMPS_190( 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)) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 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_64( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, IERR ) IF (IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & CMUMPS_274" 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_274" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( NPIV .NE. 0 ) DEALLOCATE( UIP21K ) IOLDPS = PTRIST(STEP(INODE)) IF (LASTBL) THEN IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) - & TO_UPDATE_CPT_END 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_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL CMUMPS_62( INODE, DEST, END_NIV2_LDLT, & COMM, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF END IF IF (LASTBL) THEN IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN CALL CMUMPS_759( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE CMUMPS_274 RECURSIVE SUBROUTINE CMUMPS_759( & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE CMUMPS_LOAD 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) 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_S(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX A( LA ) 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX DBLARR( max(1,KEEP(13)) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 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 (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+XXS)=S_ALL IF (KEEP(214).EQ.1) THEN CALL CMUMPS_314( 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, 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 CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) ENDIF ENDIF IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN CALL CMUMPS_627(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_80( 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_S, COMP, IFLAG, IERROR, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, .FALSE., ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL CMUMPS_314( 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, ITYPE2 & ) ENDIF CALL CMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL CMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP & ) 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_628( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) IF (KEEP(216).EQ.2) THEN CALL CMUMPS_627(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 RETURN END SUBROUTINE CMUMPS_759 SUBROUTINE CMUMPS_141( 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 ) USE CMUMPS_OOC IMPLICIT NONE INCLUDE 'cmumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW INTEGER(8) :: LA COMPLEX A( LA ) REAL UU, SEUIL TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, SLAVEF, & IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IW( LIW ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), ITLOC(N+KEEP(253)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER PTRARW(LPTRAR), PTRAIW(LPTRAR), ND( KEEP(28) ) INTEGER FRERE(KEEP(28)), FILS(N) INTEGER INTARR(max(1,KEEP(14))) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), & PTLUST_S(KEEP(28)), & & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), NBPROCFILS(KEEP(28)), & PROCNODE_STEPS(KEEP(28)), STEP(N) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(max(1,KEEP(13))) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INTEGER(8) :: POSELT INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, NBTLKJ INTEGER NASS, IEND, IOLDPS, LDAFS,allocok, IBEG_BLOCK LOGICAL LASTBL LOGICAL RESET_TO_ONE, TO_UPDATE INTEGER K109_ON_ENTRY INTEGER I,J,JJ,K,IDEB REAL UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled EXTERNAL CMUMPS_223, CMUMPS_235, & CMUMPS_227, CMUMPS_294, & CMUMPS_44 LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVSIZ,IWPOSPIV COMPLEX ONE PARAMETER (ONE=(1.0E0,0.0E0)) INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0E0)) IF (RESET_TO_ONE) THEN K109_ON_ENTRY = KEEP(109) ENDIF IBEG_BLOCK=1 NB_BLOC_FAC = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST( STEP( INODE )) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) LDAFS = NASS IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) IF (KEEP(201).EQ.1) THEN IDUMMY = -9876 CALL MUMPS_729(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+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ)) & :IOLDPS+5+2*NFRONT+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))) ENDIF ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, & ' integers' IFLAG=-13 IERROR=NASS GO TO 490 END IF 50 CONTINUE IBEGKJI = IBEG_BLOCK CALL CMUMPS_223( & NFRONT,NASS,IBEGKJI, 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) 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+KEEP(IXSZ))+6 & +IW(IOLDPS+5+KEEP(IXSZ)) PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+KEEP(IXSZ)) ENDIF ENDIF IF(INOPV.EQ. 1 .AND. STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF IF (INOPV.GE.1) THEN LASTBL = (INOPV.EQ.1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL CMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEGKJI, IEND, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (INOPV.EQ.1) GO TO 500 IF (INOPV.EQ.2) THEN CALL CMUMPS_235(IBEG_BLOCK, & NASS,N,INODE,IW,LIW,A,LA, & LDAFS, & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP,KEEP8) GOTO 50 ENDIF NPVW = NPVW + PIVSIZ IF (NASS.LE.1) THEN IFINB = -1 IF (NASS == 1) A(POSELT)=ONE/A(POSELT) ELSE CALL CMUMPS_227(IBEG_BLOCK, & NASS, N,INODE,IW,LIW,A,LA, & LDAFS, IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),PIVSIZ,KEEP(IXSZ)) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+1+KEEP(IXSZ))+6+ & IW(IOLDPS+5+KEEP(IXSZ)) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ IF (IFINB.EQ.0) GOTO 50 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN LASTBL = (IFINB.EQ.-1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL CMUMPS_294(COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEGKJI, IEND, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (IFINB.EQ.(-1)) GOTO 500 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IF (KEEP(201).EQ.1) THEN IF (.NOT.RESET_TO_ONE.OR.K109_ON_ENTRY.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_688( & 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 CALL CMUMPS_235(IBEG_BLOCK, & NASS,N,INODE,IW,LIW,A,LA, & LDAFS, & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP,KEEP8) IF (KEEP(201).EQ.1) THEN IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 JJ= IDEB TO_UPDATE=.FALSE. DO K = K109_ON_ENTRY+1, KEEP(109) I = PIVNUL_LIST(K) DO J=JJ,JJ+NASS IF (IW(J).EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN JJ= J J = J-IDEB+1 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE TO_UPDATE=.FALSE. ELSE IF (ICNTL(1).GT.0) THEN write(ICNTL(1),*) ' Internal error related ', & 'to null pivot row detection' ENDIF EXIT ENDIF ENDDO ENDIF K109_ON_ENTRY = KEEP(109) MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_688( & 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 GO TO 50 490 CONTINUE CALL CMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 JJ= IDEB TO_UPDATE=.FALSE. DO K = K109_ON_ENTRY+1, KEEP(109) I = PIVNUL_LIST(K) DO J=JJ,JJ+NASS IF (IW(J).EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN JJ= J J = J-IDEB+1 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE TO_UPDATE=.FALSE. ELSE IF (ICNTL(1).GT.0) THEN write(ICNTL(1),*) ' Internal error related ', & 'to null pivot row detection' ENDIF EXIT ENDIF ENDDO ENDIF IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) LAST_CALL = .TRUE. CALL CMUMPS_688 & ( STRAT, 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 CALL CMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE CMUMPS_141 SUBROUTINE CMUMPS_223( NFRONT, NASS, & IBEGKJI, 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV INTEGER NASS2, IBEGKJI, NNEG INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV 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(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX REAL RMAX,AMAX,TMAX,TOL REAL MAXPIV COMPLEX PIVOT,DETPIV PARAMETER(TOL = 1.0E-20) INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK 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,NASSW,IPIV INTEGER NPIVP1,ILOC,K,J INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L 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_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEGKJI + 1 TIPIV( ILOC ) = ILOC NASSW = iabs(IW(IOLDPS+3+KEEP(IXSZ))) 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_762( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL CMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO) THEN IF (abs(A(APOS)).EQ.RZERO) GO TO 630 IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF GO TO 420 ENDIF AMAX = RZERO 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, NASSW - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = max(abs(A(J1)),AMAX) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO IF (KEEP(219).NE.0) THEN RMAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX = RZERO ENDIF DO J=1,NASS - NASSW RMAX = max(abs(A(J1)),RMAX) J1 = J1 + LDAFS8 ENDDO 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, NASSW - IPIV A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO DO J=1,NASS - NASSW 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) GO TO 415 ENDIF IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN IF(SEUIL .GT. epsilon(SEUIL)) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL ENDIF PIVOT = A(POSPV1) WRITE(*,*) 'WARNING matrix may be singular' KEEP(98) = KEEP(98)+1 GO TO 415 ENDIF ENDIF ENDIF IF (max(AMAX,abs(PIVOT)) .LE. TOL) GOTO 460 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (AMAX.LE.TOL) GO TO 460 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 + LDAFS8 DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDAFS8 ENDDO 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 IF (KEEP(219).NE.0) THEN TMAX = max(SEUIL/UULOC,real(A(APOSMAX+int(JMAX,8)))) ELSE TMAX = SEUIL/UULOC ENDIF IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+int(NASS,8) IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+int(NASS,8) TMAX=max(TMAX,abs(A(JJ))) ENDDO 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 ) GOTO 460 ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF (KEEP(258).NE.0) THEN CALL CMUMPS_762(DETPIV, DKEEP(6), KEEP(259)) ENDIF PIVSIZ = 2 KEEP(105) = KEEP(105)+1 415 CONTINUE DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEGKJI + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEGKJI + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEGKJI + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF CALL CMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, KEEP(219), KEEP(50), & KEEP(IXSZ)) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL CMUMPS_680( 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 (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE RETURN END SUBROUTINE CMUMPS_223 SUBROUTINE CMUMPS_235( & IBEG_BLOCK, & NASS, N, INODE, & IW, LIW, A, LA, & LDAFS, & IOLDPS, POSELT, & LKJIB_ORIG, LKJIB, LKJIT, KEEP,KEEP8 ) IMPLICIT NONE INTEGER NASS,N,LIW INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER (8) :: POSELT INTEGER (8) :: LDAFS8 INTEGER LDAFS, IBEG_BLOCK INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1 INTEGER HF INTEGER(8) :: LPOS,UPOS,APOS INTEGER LKJIT INTEGER LKJIBOLD, IROW INTEGER J, Block INTEGER BLSIZE COMPLEX ONE, ALPHA PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) LKJIBOLD = LKJIB NPIV = IW(IOLDPS+1+KEEP(IXSZ)) JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 IF ( LKJIW .NE. LKJIB ) THEN NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) LKJIB = min0(LKJIB, NASS - NPIV) ELSE LKJIB = NASS - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = NASS ENDIF ELSEIF (JROW2.LT.NASS) THEN IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) ENDIF IBEG_BLOCK = NPIV + 1 IF (LKJIW.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF ( NASS - JROW2 > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NASS - JROW2 END IF IF ( NASS - JROW2 .GT. 0 ) THEN DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDAFS8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDAFS8 + int(IROW - 1,8) APOS = POSELT + int(IROW-1,8) * LDAFS8 + int(IROW - 1,8) DO J=1, Block CALL cgemv( 'T', LKJIW, Block - J + 1, ALPHA, & A( LPOS ), LDAFS, A( UPOS ), LDAFS, & ONE, A( APOS ), LDAFS ) LPOS = LPOS + LDAFS8 APOS = APOS + LDAFS8 + 1_8 UPOS = UPOS + 1_8 END DO LPOS = POSELT + int(IROW-1+Block,8) * LDAFS8 & + int(NPBEG-1,8) UPOS = POSELT + int(NPBEG-1,8) * LDAFS8 + int(IROW-1,8) APOS = POSELT + int( IROW - 1 + Block,8 ) * LDAFS8 & + int(IROW - 1,8) CALL cgemm( 'N','N', Block, NASS - IROW + 1 - Block, LKJIW, & ALPHA, A( UPOS ), LDAFS, & A( LPOS ), LDAFS, ONE, A( APOS ), LDAFS ) END DO END IF END IF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_235 SUBROUTINE CMUMPS_227 & ( IBEG_BLOCK, NASS, N, INODE, IW, LIW, & A, LA, LDAFS, & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,PIVSIZ, & XSIZE) IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER :: LIW COMPLEX A(LA) INTEGER IW(LIW) COMPLEX VALPIV INTEGER IOLDPS, NCB1 INTEGER LKJIT, IBEG_BLOCK INTEGER NPIV,JROW2 INTEGER(8) :: APOS INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NASS,N,INODE,IFINB,LKJIB,LDAFS, & NPBEG INTEGER NEL2 INTEGER XSIZE COMPLEX ONE, ALPHA COMPLEX ZERO INTEGER PIVSIZ,NPIV_NEW INTEGER(8) :: IBEG, IEND, IROW INTEGER :: J2 COMPLEX SWOP,DETPIV,MULT1,MULT2 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 = IW(IOLDPS+1+XSIZE) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) ENDIF JROW2 = IW(IOLDPS+3+XSIZE) NPBEG = IBEG_BLOCK NEL2 = JROW2 - NPIV_NEW IF (NEL2.EQ.0) THEN IF (JROW2.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) A(APOS) = VALPIV LPOS = APOS + LDAFS8 CALL ccopy(NASS-NPIV_NEW, A(LPOS), LDAFS, A(APOS+1_8), 1) CALL CMUMPS_XSYR('U', NEL2, -VALPIV, A(LPOS), LDAFS, & A(LPOS+1_8), LDAFS) CALL cscal(NASS-NPIV_NEW, VALPIV, A(LPOS), LDAFS) IF (NEL2.GT.0) THEN K1POS = LPOS + int(NEL2,8)*LDAFS8 NCB1 = NASS - JROW2 CALL cgeru(NEL2, NCB1 , ALPHA, A(APOS+1_8), 1, & A(K1POS), LDAFS, A(K1POS+1_8), LDAFS) 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) A(POSPV2) = A(POSPV1)/DETPIV A(POSPV1) = SWOP/DETPIV A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV 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 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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 = JROW2+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A(POSPV1)*A(K1)+A(POSPV1+1_8)*A(K2)) MULT2 = - (A(POSPV1+1_8)*A(K1)+A(POSPV2)*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 ENDIF RETURN END SUBROUTINE CMUMPS_227 RECURSIVE SUBROUTINE CMUMPS_263( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER 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) ) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX DBLARR( max(1,KEEP(13)) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER MUMPS_275 EXTERNAL MUMPS_275 INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok 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 ) LAELL = int(NPIV,8) * int(NCOLU,8) IF ( LRLU .LT. LAELL ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_731(LAELL - LRLUS, IERROR) GOTO 700 END IF CALL CMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731(LAELL - LRLU, IERROR) GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLU) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_COMPLEX, & COMM, IERR ) 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 (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_731(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) ENDIF DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), & SLAVEF ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDDO DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IOLDPS = PTRIST(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAVES_TOT = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAVES_TOT + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 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 FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL CMUMPS_190(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IW( IOLDPS + 6 + KEEP(IXSZ) ) = IW( IOLDPS + 6+ KEEP(IXSZ) ) + 1 IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 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_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL CMUMPS_62( INODE, DEST, END_NIV2_LDLT, & COMM, 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 CALL CMUMPS_759( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE CMUMPS_263 SUBROUTINE CMUMPS_38( 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_38 RECURSIVE SUBROUTINE CMUMPS_80 & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, & NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & SHIFT_VAL_SON, LDA, 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE CMUMPS_OOC USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) 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, LDA INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL INVERT 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 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX DBLARR( max(1,KEEP(13)) ) 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 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 BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 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_80' CALL CMUMPS_44( MYID, SLAVEF, COMM ) 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. INVERT ) 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.INVERT).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. INVERT ) 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. INVERT ) 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. INVERT ) 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 NBPROCFILS( STEP(IROOT) ) = -1 CALL CMUMPS_284(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, IERROR ) IF (IFLAG.LT.0) THEN CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF ELSE NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT)) - 1 IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_681(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL CMUMPS_580(IERR) ENDIF CALL CMUMPS_507(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_500( & 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_285( 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), INVERT, & 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_285( 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), INVERT, & 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,': Error in b&scbroot: pb compress' WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL CMUMPS_648( 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, INVERT, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 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_80" CALL CMUMPS_44( MYID, SLAVEF, COMM ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING CMUMPS_80" IFLAG = -20 IERROR = SIZE_MSG CALL CMUMPS_44( MYID, SLAVEF, COMM ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN END SUBROUTINE CMUMPS_80 SUBROUTINE CMUMPS_285( 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, INVERT, & 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 INVERT 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. INVERT ) 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_285 SUBROUTINE CMUMPS_164 &( 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_99( 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 CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. 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_164 SUBROUTINE CMUMPS_165( 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 RETURN END SUBROUTINE CMUMPS_165 SUBROUTINE CMUMPS_99( 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_99 SUBROUTINE CMUMPS_290(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 INTEGER STATUS(MPI_STATUS_SIZE) COMPLEX WK( MBLOCK * NBLOCK ) LOGICAL JUPDATE 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 RETURN END SUBROUTINE CMUMPS_290 SUBROUTINE CMUMPS_156(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 INTEGER STATUS(MPI_STATUS_SIZE) COMPLEX WK( MBLOCK * NBLOCK ) LOGICAL JUPDATE 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 RETURN END SUBROUTINE CMUMPS_156 SUBROUTINE CMUMPS_284(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, IERROR ) IMPLICIT NONE INCLUDE 'cmumps_root.h' INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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 ), PTRAIW(N), PTRARW( N ) INTEGER INTARR(max(1,KEEP(14))) COMPLEX DBLARR(max(1,KEEP(13))) 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_760 ( 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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_284 SUBROUTINE CMUMPS_760 & ( 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_760 INTEGER FUNCTION CMUMPS_IXAMAX(n,x,incx) complex x(*) real smax integer i,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)go to 20 ix = 1 smax = abs(x(1)) ix = ix + incx do 10 i = 2,n if(abs(x(ix)).le.smax) go to 5 CMUMPS_IXAMAX = i smax = abs(x(ix)) 5 ix = ix + incx 10 continue return 20 smax = abs(x(1)) do 30 i = 2,n if(abs(x(i)).le.smax) go to 30 CMUMPS_IXAMAX = i smax = abs(x(i)) 30 continue return END FUNCTION CMUMPS_IXAMAX SUBROUTINE CMUMPS_XSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) CHARACTER UPLO INTEGER INCX, LDA, N COMPLEX ALPHA COMPLEX A( LDA, * ), X( * ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) INTEGER I, INFO, IX, J, JX, KX COMPLEX TEMP INTRINSIC max INFO = 0 IF( UPLO.NE.'U' .AND. UPLO.NE.'L' ) THEN INFO = 1 ELSE IF( N.LT.0 ) THEN INFO = 2 ELSE IF( INCX.EQ.0 ) THEN INFO = 5 ELSE IF( LDA.LT.max( 1, N ) ) THEN INFO = 7 END IF IF( INFO.NE.0 ) THEN WRITE(*,*) "Internal error in CMUMPS_XSYR" CALL MUMPS_ABORT() RETURN END IF IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) ) & RETURN IF( INCX.LE.0 ) THEN KX = 1 - ( N-1 )*INCX ELSE IF( INCX.NE.1 ) THEN KX = 1 END IF IF( UPLO.EQ.'U' ) THEN IF( INCX.EQ.1 ) THEN DO 20 J = 1, N IF( X( J ).NE.ZERO ) THEN TEMP = ALPHA*X( J ) DO 10 I = 1, J A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX DO 40 J = 1, N IF( X( JX ).NE.ZERO ) THEN TEMP = ALPHA*X( JX ) IX = KX DO 30 I = 1, J A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 ) THEN DO 60 J = 1, N IF( X( J ).NE.ZERO ) THEN TEMP = ALPHA*X( J ) DO 50 I = J, N A( I, J ) = A( I, J ) + X( I )*TEMP 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80 J = 1, N IF( X( JX ).NE.ZERO ) THEN TEMP = ALPHA*X( JX ) IX = JX DO 70 I = J, N A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF RETURN END SUBROUTINE CMUMPS_XSYR mumps-4.10.0.dfsg/src/smumps_struc_def.F0000644000175300017530000000430311562233065020364 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE SMUMPS_STRUC_DEF INCLUDE 'smumps_struc.h' END MODULE SMUMPS_STRUC_DEF mumps-4.10.0.dfsg/src/smumps_load.F0000644000175300017530000065321311562233065017337 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE SMUMPS_LOAD implicit none PUBLIC :: SMUMPS_188, SMUMPS_185, & SMUMPS_189, SMUMPS_190, & SMUMPS_183, SMUMPS_187, & SMUMPS_186, SMUMPS_409, & SMUMPS_384, SMUMPS_461, & SMUMPS_467, SMUMPS_471, & SMUMPS_472, & SMUMPS_791, SMUMPS_790, & SMUMPS_792, SMUMPS_500, & SMUMPS_501, SMUMPS_520, & SMUMPS_513, & SMUMPS_514, SMUMPS_512 & ,SMUMPS_533, & SMUMPS_819, SMUMPS_818, & SMUMPS_820, SMUMPS_554, & SMUMPS_553, & SMUMPS_555 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) INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: FUTURE_NIV2 DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM #else DOUBLE PRECISION, SAVE, PRIVATE :: LAST_LOAD_SENT, & DM_LAST_MEM_SENT #endif 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,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 SMUMPS_188( COST_SUBTREE_ARG, K64, K66, & MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER K64, K66 INTEGER(8)::MAXS DOUBLE PRECISION T64, T66 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/1000_8) COST_SUBTREE = COST_SUBTREE_ARG END SUBROUTINE SMUMPS_188 SUBROUTINE SMUMPS_791 ( & 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_810 EXTERNAL MUMPS_810 LP = ICNTL(1) IN = INODE NBSPLIT = 0 NUMORG_SPLIT = 0 DO WHILE & ( & ( MUMPS_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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_791 SUBROUTINE SMUMPS_790 ( & 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_810 EXTERNAL MUMPS_810 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_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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_790 SUBROUTINE SMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & SON_SLAVE_LIST, NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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, & NCB, KEEP(500), NBSPLIT, & NSLSON, SIZE_SLAVES_LIST 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)) 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_792 SUBROUTINE SMUMPS_472( & 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_499( & 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_504( & 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_545' CALL MUMPS_ABORT() ENDIF ENDDO ELSE IF ( KEEP(48) == 5 ) THEN CALL SMUMPS_518( & 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_518' CALL MUMPS_ABORT() ENDIF ENDDO ELSE WRITE(*,*) "Strategy 6 not implemented" CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE SMUMPS_472 SUBROUTINE SMUMPS_499( & 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_12 EXTERNAL MUMPS_12 IF ( KEEP(48) == 0 .AND. KEEP(50) .NE. 0) THEN write(*,*) "Internal error 2 in SMUMPS_499." CALL MUMPS_ABORT() END IF IF ( KEEP(48) == 3 .AND. KEEP(50) .EQ. 0) THEN write(*,*) "Internal error 3 in SMUMPS_499." 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_409 & (MEM_DISTRIB, & CAND_OF_NODE, & & KEEP(69), SLAVEF, MSG_SIZE, & NMB_OF_CAND ) ELSE ITEMP=SMUMPS_186(KEEP(69),MEM_DISTRIB,MSG_SIZE) NMB_OF_CAND = SLAVEF - 1 END IF NSLAVES_LESS = max(ITEMP,1) NSLAVES_NODE = MUMPS_12(KEEP8(21), KEEP(48), & KEEP(50),SLAVEF, & NCB, NFRONT, NSLAVES_LESS, NMB_OF_CAND) CALL MUMPS_441( & KEEP,KEEP8, SLAVEF, & TAB_POS, & NSLAVES_NODE, NFRONT, NCB & ) IF (FORCE_CAND) THEN CALL SMUMPS_384(MEM_DISTRIB(0), & CAND_OF_NODE, SLAVEF, NSLAVES_NODE, & SLAVES_LIST) ELSE CALL SMUMPS_189(MEM_DISTRIB(0), & MSG_SIZE, SLAVES_LIST, NSLAVES_NODE) ENDIF RETURN END SUBROUTINE SMUMPS_499 SUBROUTINE SMUMPS_185( id, MEMORY_MD_ARG, MAXS ) USE SMUMPS_COMM_BUFFER USE SMUMPS_STRUC_DEF 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 INTEGER,DIMENSION(:),POINTER:: KEEP PARAMETER( ZERO=0.0d0 ) INTEGER WHAT INTEGER(8) MEMORY_MD, LA STEP_TO_NIV2_LOAD=>id%ISTEP_TO_INIV2 CAND_LOAD=>id%CANDIDATES ND_LOAD=>id%ND_STEPS KEEP_LOAD=>id%KEEP KEEP =>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 = KEEP(69) IF ( KEEP(47) .le. 0 .OR. KEEP(47) .gt. 4 ) THEN write(*,*) "Internal error 1 in SMUMPS_185" CALL MUMPS_ABORT() END IF CHK_LD=dble(0) BDC_MEM = ( KEEP(47) >= 2 ) BDC_POOL = ( KEEP(47) >= 3 ) BDC_SBTR = ( KEEP(47) >= 4 ) BDC_M2_MEM = ( ( KEEP(80) == 2 .OR. KEEP(80) == 3 ) & .AND. KEEP(47) == 4 ) BDC_M2_FLOPS = ( KEEP(80) == 1 & .AND. KEEP(47) .GE. 1 ) BDC_MD = (KEEP(86)==1) SBTR_WHICH_M = KEEP(90) REMOVE_NODE_FLAG=.FALSE. REMOVE_NODE_FLAG_MEM=.FALSE. REMOVE_NODE_COST_MEM=dble(0) REMOVE_NODE_COST=dble(0) IF (KEEP(80) .LT. 0 .OR. KEEP(80)>3) THEN WRITE(*,*) "Unimplemented KEEP(80) Strategy" CALL MUMPS_ABORT() ENDIF IF ((KEEP(80) == 2 .OR. KEEP(80)==3 ).AND. KEEP(47).NE.4) & THEN WRITE(*,*) "Internal error 3 in SMUMPS_185" CALL MUMPS_ABORT() END IF IF (KEEP(81) == 1 .AND. KEEP(47) < 2) THEN WRITE(*,*) "Internal error 2 in SMUMPS_185" CALL MUMPS_ABORT() ENDIF BDC_POOL_MNG = ((KEEP(81) == 1).AND.(KEEP(47) >= 2)) IF(KEEP(76).EQ.4)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST ENDIF IF(KEEP(76).EQ.5)THEN COST_TRAV=>id%COST_TRAV ENDIF IF(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 ALLOCATE(NIV2(id%NSLAVES), NB_SON(KEEP(28)), & POOL_NIV2(100),POOL_NIV2_COST(100), & stat=allocok) NB_SON=id%NE_STEPS NIV2=dble(0) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in SMUMPS_185' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES + 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_185' 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_185' 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_185' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF LU_USAGE=dble(0) MD_MEM=int(0,8) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN ALLOCATE(CB_COST_MEM(2*2000*id%NSLAVES), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in SMUMPS_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF SBTR_CUR = dble(0) SBTR_MEM = dble(0) END IF CALL MUMPS_546(K34_LOC,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_185' id%INFO(1) = -13 id%INFO(2) = LBUF_LOAD_RECV RETURN ENDIF BUF_LOAD_SIZE = BUF_LOAD_SIZE * 20 CALL SMUMPS_54( 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_425(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_460( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEMORY_MD),dble(0) ,MYID, IERR ) WHAT=9 MEMORY_SENT = dble(LA-MAX_SURF_MASTER)-MAX_SBTR & - max( dble(LA) * dble(3) / dble(100), & dble(2) * dble(max(KEEP(5),KEEP(6))) * dble(KEEP(127))) IF (KEEP(12) > 25) THEN MEMORY_SENT = MEMORY_SENT - & dble(KEEP(12))*0.2d0*dble(LA)/100.0d0 ENDIF TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL SMUMPS_460( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MEMORY_SENT, & dble(0),MYID, IERR ) ENDIF RETURN END SUBROUTINE SMUMPS_185 SUBROUTINE SMUMPS_190( CHECK_FLOPS,PROCESS_BANDE, & INC_LOAD, KEEP,KEEP8 ) USE SMUMPS_COMM_BUFFER 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 (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_77( 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, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_190",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_190 SUBROUTINE SMUMPS_471( SSARBR, & PROCESS_BANDE_ARG, MEM_VALUE, NEW_LU, INC_MEM_ARG, & KEEP,KEEP8,LRLU) USE SMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_VALUE, INC_MEM_ARG, NEW_LU,LRLU 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 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_471." 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 #if defined(STATS_DYNAMIC_MEMORY) WRITE(*,*)MYID,': end of Incoherent state at time=', & MPI_WTIME()-TIME_REF #endif 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. #if defined(STATS_DYNAMIC_MEMORY) WRITE(*,*)MYID,': Begin of Incoherent state (1) at time=', & MPI_WTIME()-TIME_REF #endif 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_471', & 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.1d0*dble(LRLU))))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.1d0*dble(LRLU))))THEN IF ( abs( TMP_MEM-DM_LAST_MEM_SENT) > & DM_THRES_MEM ) THEN IERR = 0 SEND_MEM = TMP_MEM #endif 111 CONTINUE CALL SMUMPS_77( & 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,IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_471",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_471 INTEGER FUNCTION SMUMPS_186( 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_426(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_186 = NLESS RETURN END FUNCTION SMUMPS_186 SUBROUTINE SMUMPS_189(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_558(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_189 SUBROUTINE SMUMPS_183( INFO1, IERR ) USE SMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER, intent(in) :: INFO1 INTEGER, intent(out) :: IERR IERR=0 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_58( IERR ) CALL SMUMPS_150( MYID, COMM_LD, & BUF_LOAD_RECV, LBUF_LOAD_RECV, & LBUF_LOAD_RECV_BYTES ) DEALLOCATE(BUF_LOAD_RECV) END SUBROUTINE SMUMPS_183 #if defined (LAMPORT_) RECURSIVE SUBROUTINE SMUMPS_467(COMM, KEEP) #else SUBROUTINE SMUMPS_467(COMM, KEEP) #endif IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MSGTAG, MSGLEN, MSGSOU,COMM INTEGER KEEP(500) 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(65)=KEEP(65)+1 MSGTAG = STATUS( MPI_TAG ) MSGSOU = STATUS( MPI_SOURCE ) IF ( MSGTAG .NE. UPDATE_LOAD) THEN write(*,*) "Internal error 1 in SMUMPS_467", & 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_467", & 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_187( MSGSOU, BUF_LOAD_RECV, & LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES ) GOTO 10 ENDIF RETURN END SUBROUTINE SMUMPS_467 RECURSIVE SUBROUTINE SMUMPS_187 & ( MSGSOU, BUFR, LBUFR, LBUFR_BYTES ) 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_330 INTEGER MUMPS_330 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_819(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_187" 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_187" 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_187" 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_816(INODE_RECEIVED) ELSEIF(BDC_M2_FLOPS) THEN CALL SMUMPS_817(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_330(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_187" 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. & sqrt(epsilon(LOAD_RECEIVED)))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 WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() 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_187' 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_187' 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_187' 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_187" CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE SMUMPS_187 integer function SMUMPS_409 & (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_426(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_409 = nless return end function SMUMPS_409 subroutine SMUMPS_384 & (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_558 NMB_OF_CAND = CAND(SLAVEF+1) if(nslaves_inode.ge.NPROCS .or. & nslaves_inode.gt.NMB_OF_CAND) then write(*,*)'Internal error in SMUMPS_384', & 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_558(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_384 SUBROUTINE SMUMPS_425(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_425 SUBROUTINE SMUMPS_426(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_426 SUBROUTINE SMUMPS_461(MYID, SLAVEF, COMM, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, NSLAVES,INODE) USE SMUMPS_COMM_BUFFER 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 DOUBLE PRECISION MEM_INCREMENT ( NSLAVES ) DOUBLE PRECISION FLOPS_INCREMENT( NSLAVES ) DOUBLE PRECISION CB_BAND( NSLAVES ) IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN WHAT=1 ELSE WHAT=19 ENDIF #if ! defined(OLD_LOAD_MECHANISM) FUTURE_NIV2(MYID+1) = FUTURE_NIV2(MYID+1) - 1 IF ( FUTURE_NIV2(MYID+1) < 0 ) THEN WRITE(*,*) "Internal error in SMUMPS_461" CALL MUMPS_ABORT() ENDIF IF ( FUTURE_NIV2(MYID + 1) == 0 ) THEN 112 CONTINUE CALL SMUMPS_502(COMM,MYID,SLAVEF, & dble(MAX_SURF_MASTER),IERR) IF (IERR == -1 ) THEN CALL SMUMPS_467(COMM_LD, KEEP) GOTO 112 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_461", & IERR CALL MUMPS_ABORT() ENDIF TAB_MAXS(MYID) = TAB_MAXS(MYID) + int(MAX_SURF_MASTER,8) ENDIF #endif IF ( NSLAVES /= TAB_POS(SLAVEF + 2) ) THEN write(*,*) "Error 1 in SMUMPS_461", & 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_524(BDC_MEM, COMM, MYID, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT,IERR) IF ( IERR == -1 ) THEN CALL SMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_461", & 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 RETURN END SUBROUTINE SMUMPS_461 SUBROUTINE SMUMPS_500( & POOL, LPOOL, & PROCNODE, KEEP,KEEP8, SLAVEF, COMM, MYID, STEP, N, & ND, FILS ) USE SMUMPS_COMM_BUFFER 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_330 EXTERNAL MUMPS_330 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_330( 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_460( WHAT, & COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0),MYID, IERR ) POOL_LAST_COST_SENT = COST POOL_MEM(MYID)=COST IF ( IERR == -1 )THEN CALL SMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_500", & IERR CALL MUMPS_ABORT() ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_500 SUBROUTINE SMUMPS_501( & OK,INODE,POOL,LPOOL,MYID,SLAVEF,COMM,KEEP,KEEP8) USE SMUMPS_COMM_BUFFER 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_283,MUMPS_170 LOGICAL MUMPS_283,MUMPS_170 IF((INODE.LE.0).OR.(INODE.GT.N_LOAD)) THEN RETURN ENDIF IF (.NOT.MUMPS_170( & PROCNODE_LOAD(STEP_LOAD(INODE)), NPROCS) & ) THEN RETURN ENDIF IF(MUMPS_283(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_460( & WHAT, COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0),MYID, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 1 in SMUMPS_501", & 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_460( & WHAT, COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0) ,MYID,IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_467(COMM_LD, KEEP) GOTO 112 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 3 in SMUMPS_501", & 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_501 SUBROUTINE SMUMPS_504 & (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_504" 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_558(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_558(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 #if defined (OLD_PART) 887 CONTINUE #endif 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_504" 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_504" 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_504' 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_504' 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_504' 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 #if ! defined (OLD_PART) i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 #if ! defined (PART1_) 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_504' 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 #endif 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 #if ! defined (PART1_) ENDIF #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 ! defined (PART1_) 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 #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 #else DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/ & dble(i)).NE.0)THEN GOTO 555 ENDIF ENDDO 555 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(i)) DO J=1,i IF(NB_ROWS(J)+X.GT.K821/NCB)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & ((K821/NCB)-NB_ROWS(J)) NB_ROWS(J)=(K821/NFRONT) ELSE IF ((TEMP(J)+dble((NB_ROWS(J)+X))* & dble(NFRONT)).GT. & PEAK)THEN AFFECTED=int((PEAK-(TEMP(J)+dble(NB_ROWS(J))* & dble(NFRONT))/dble(NFRONT)) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED NB_ROWS(J)=NB_ROWS(J)+AFFECTED ELSE NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDIF IF(((TEMP(J)+dble(NB_ROWS(J))*dble(NFRONT)) & .GT. PEAK) & .AND.(SMALL_SET.LT.OTHERS))THEN WRITE(*,*)MYID, & ':Internal error 8 in SMUMPS_504' SMALL_SET=SMALL_SET+1 CALL MUMPS_ABORT() ENDIF ENDDO SOMME=dble(0) DO J=1,CHOSEN SOMME=SOMME+NB_ROWS(J) ENDDO IF(ADDITIONNAL_ROWS.NE.0) THEN DO J=1,CHOSEN IF(NB_ROWS(J).LT.0)THEN WRITE(*,*)MYID, & ':Internal error 9 in SMUMPS_504' CALL MUMPS_ABORT() ENDIF IF ((TEMP(J)+dble(NB_ROWS(J)) & *dble(NFRONT)).GT. & PEAK)THEN WRITE(*,*)MYID, & ':Internal error 10 in SMUMPS_504' CALL MUMPS_ABORT() ENDIF IF ((TEMP(J)+dble(NB_ROWS(J)+ & ADDITIONNAL_ROWS)*dble(NFRONT)).GE. & PEAK)THEN AFFECTED=int((PEAK-(TEMP(J)+ & dble(NB_ROWS(J))* & dble(NFRONT))/dble(NFRONT)) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED NB_ROWS(J)=NB_ROWS(J)+AFFECTED IF((TEMP(J)+dble(NFRONT)* & dble(NB_ROWS(J))).GT. & PEAK)THEN WRITE(*,*)MYID, & ':Internal error 11 in SMUMPS_504' CALL MUMPS_ABORT() ENDIF ELSE NB_ROWS(J)=NB_ROWS(J)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 666 ENDDO IF(SMALL_SET.EQ.(NUMBER_OF_PROCS)) THEN NB_ROWS=0 GOTO 887 ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF(NB_ROWS(i)+ADDITIONNAL_ROWS.LT.K821/NFRONT) & THEN NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-(K821/ & NFRONT & -NB_ROWS(i)) NB_ROWS(i)=K821/NFRONT ENDIF i=i+1 ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/dble(i)) & .NE.0)THEN GOTO 372 ENDIF ENDDO 372 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 ENDIF #endif 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_504' CALL MUMPS_ABORT() ENDIF CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*) & 'Internal error 13 in SMUMPS_504' 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_504' 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_504' CALL MUMPS_ABORT() ENDIF END SUBROUTINE SMUMPS_504 SUBROUTINE SMUMPS_518 & (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_442 INTEGER MUMPS_442 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_442(int(NCB,8)*int(KMAX,8),K50,KMAX,NCB) NB_ROWS=0 CALL MUMPS_558(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_511(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_558(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 #if ! defined (OOC_PAR_MEM_SLAVE_SELECT) && ! defined (OOC_PAR_MEM2) CALL MUMPS_503(WHAT, KEEP,KEEP8, NCB, & NFRONT, min(NCB,OTHERS), J, X8) #endif 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_558(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_518' 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_518' 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_518' 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_518' 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_558(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_518' 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_558(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_518' 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_518' CALL MUMPS_ABORT() ENDIF X=X+1 ENDIF ENDDO DO i=CHOSEN+1,NUMBER_OF_PROCS SLAVES_LIST(i)=TEMP_ID(i) ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*)MYID, & ': Internal error 17 in SMUMPS_518', & POS,NCB+1 CALL MUMPS_ABORT() ENDIF END SUBROUTINE SMUMPS_518 SUBROUTINE SMUMPS_520 & (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_508, & MUMPS_170 LOGICAL SMUMPS_508, & MUMPS_170 NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF(KEEP(47).LT.2)THEN WRITE(*,*)'SMUMPS_520 must & be called with K47>=2' CALL MUMPS_ABORT() ENDIF IF((INODE.GT.0).AND.(INODE.LE.N))THEN MEM_COST=SMUMPS_543(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_543(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_170(PROCNODE(STEP(INODE)), & SLAVEF))THEN WRITE(*,*) & 'Internal error 1 in SMUMPS_520' CALL MUMPS_ABORT() ENDIF UPPER=.FALSE. RETURN ENDIF INODE=POOL(LPOOL-2-NBTOP) UPPER=.TRUE. RETURN ENDIF ENDIF UPPER=.TRUE. END SUBROUTINE SMUMPS_520 SUBROUTINE SMUMPS_513(WHAT) IMPLICIT NONE LOGICAL WHAT IF(.NOT.BDC_POOL_MNG)THEN WRITE(*,*)'SMUMPS_513 & 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_513 DOUBLE PRECISION FUNCTION SMUMPS_543( INODE ) IMPLICIT NONE INTEGER INODE,LEVEL,i,NELIM,NFR DOUBLE PRECISION COST EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_330( 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_543=COST RETURN END FUNCTION SMUMPS_543 RECURSIVE SUBROUTINE SMUMPS_515(FLAG,COST,COMM) USE SMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL FLAG DOUBLE PRECISION COST DOUBLE PRECISION TO_BE_SENT EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_460( WHAT, & COMM, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, & TO_BE_SENT, & MYID, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_467(COMM_LD, KEEP_LOAD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_500", & IERR CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE SMUMPS_515 SUBROUTINE SMUMPS_512(INODE,STEP,NSTEPS,PROCNODE,FRERE, & NE,COMM,SLAVEF,MYID,KEEP,KEEP8,N) USE SMUMPS_COMM_BUFFER 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_170,MUMPS_275 LOGICAL MUMPS_170 INTEGER i,NCB,NELIM INTEGER MUMPS_275 INTEGER FATHER_NODE,FATHER,WHAT,IERR EXTERNAL MUMPS_330 INTEGER MUMPS_330 IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*)MYID,': Problem in SMUMPS_512' 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_170(PROCNODE(STEP(FATHER_NODE)), & SLAVEF)) THEN RETURN ENDIF FATHER=MUMPS_275(PROCNODE(STEP(FATHER_NODE)),SLAVEF) IF(FATHER.EQ.MYID)THEN IF(BDC_M2_MEM)THEN CALL SMUMPS_816(FATHER_NODE) ELSEIF(BDC_M2_FLOPS)THEN CALL SMUMPS_817(FATHER_NODE) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN IF(MUMPS_330(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_519(WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB, KEEP(81),MYID, & FATHER, IERR) IF (IERR == -1 ) THEN CALL SMUMPS_467(COMM, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_512", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE END SUBROUTINE SMUMPS_512 SUBROUTINE SMUMPS_514(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_515(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_515(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_514 RECURSIVE SUBROUTINE SMUMPS_816(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_816' 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 POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & SMUMPS_543(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_515(REMOVE_NODE_FLAG_MEM,MAX_M2,COMM_LD) NIV2(1+MYID)=MAX_M2 ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_816 RECURSIVE SUBROUTINE SMUMPS_817(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_817' 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 POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & SMUMPS_542(INODE) POOL_SIZE=POOL_SIZE+1 MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL SMUMPS_515(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_817 DOUBLE PRECISION FUNCTION SMUMPS_542(INODE) INTEGER INODE INTEGER NFRONT,NELIM,i,LEVEL EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_330( PROCNODE_LOAD(STEP_LOAD(INODE)), NPROCS ) COST=dble(0) CALL MUMPS_511(NFRONT,NELIM,NELIM, & KEEP_LOAD(50),LEVEL,COST) SMUMPS_542=COST RETURN END FUNCTION SMUMPS_542 INTEGER FUNCTION SMUMPS_541( 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_541=COST_CB RETURN END FUNCTION SMUMPS_541 SUBROUTINE SMUMPS_533(SLAVEF,NMB_OF_CAND, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, & NSLAVES,INODE) USE SMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, NASS, NSLAVES INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, intent(in) :: NMB_OF_CAND INTEGER, INTENT (IN) :: LIST_SLAVES( NMB_OF_CAND ) INTEGER KEEP(500),INODE INTEGER(8) KEEP8(150) INTEGER allocok DOUBLE PRECISION MEM_COST,FCT_COST DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE ::EMPTY_ARRAY, & DELTA_MD,EMPTY_ARRAY2 INTEGER NBROWS_SLAVE,i,WHAT,IERR,NPROCS_LOC LOGICAL FORCE_CAND MEM_COST=dble(0) FCT_COST=dble(0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. NPROCS_LOC=SLAVEF-1 ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) NPROCS_LOC=NMB_OF_CAND END IF IF(FORCE_CAND)THEN CALL SMUMPS_540(INODE,FCT_COST, & MEM_COST,NPROCS_LOC,NASS) ELSE CALL SMUMPS_540(INODE,FCT_COST, & MEM_COST,SLAVEF-1,NASS) ENDIF DO i=1,SLAVEF IDWLOAD(i)=i-1 ENDDO ALLOCATE(EMPTY_ARRAY(NPROCS_LOC),DELTA_MD(NPROCS_LOC), & EMPTY_ARRAY2(NPROCS_LOC), & stat=allocok) DO i = 1, NSLAVES NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) DELTA_MD( i ) = FCT_COST - dble(NBROWS_SLAVE)* & dble(NASS) END DO IF(FORCE_CAND)THEN DO i=NSLAVES+1,NPROCS_LOC DELTA_MD( i ) = FCT_COST ENDDO ELSE DO i=NSLAVES+1,SLAVEF-1 DELTA_MD( i ) = FCT_COST ENDDO ENDIF WHAT=7 111 CONTINUE CALL SMUMPS_524(.FALSE., COMM_LD, MYID, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NPROCS_LOC, LIST_SLAVES,0, & EMPTY_ARRAY, & DELTA_MD,EMPTY_ARRAY2,WHAT, IERR) IF ( IERR == -1 ) THEN CALL SMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_533", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif DO i = 1, NSLAVES MD_MEM(LIST_SLAVES(i))=MD_MEM(LIST_SLAVES(i))+ & int(DELTA_MD( 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 ENDDO #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif DEALLOCATE(EMPTY_ARRAY) DEALLOCATE(DELTA_MD) END SUBROUTINE SMUMPS_533 SUBROUTINE SMUMPS_540(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_540 SUBROUTINE SMUMPS_819(INODE) IMPLICIT NONE INTEGER INODE INTEGER i,J,SON,NSLAVES_TEMP,POS_TEMP,K INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_275( & 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_819 SUBROUTINE SMUMPS_820(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_820 SUBROUTINE SMUMPS_554(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_554 SUBROUTINE SMUMPS_818(INODE,MAX_MEM,PROC) IMPLICIT NONE INTEGER INODE,PROC INTEGER i,POS,NSLAVES,SLAVE,NCAND,J,NELIM,NCB,NFRONT,SON,K INTEGER allocok EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_818' CALL MUMPS_ABORT() ENDIF ALLOCATE( CONCERNED(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_818' CALL MUMPS_ABORT() ENDIF ALLOCATE( RECV_BUF(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_818' 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_330(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_543(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_330(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_818' 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_818 SUBROUTINE SMUMPS_553(MIN_PROC,POOL, & LPOOL,INODE) IMPLICIT NONE INTEGER INODE,LPOOL,MIN_PROC INTEGER POOL(LPOOL) EXTERNAL MUMPS_275 INTEGER MUMPS_275 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_275(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_275(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_553 SUBROUTINE SMUMPS_555(POOL, LPOOL,KEEP,KEEP8) IMPLICIT NONE INTEGER LPOOL,POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER i,POS EXTERNAL MUMPS_283 LOGICAL MUMPS_283 IF(.NOT.BDC_SBTR) RETURN POS=0 DO i=NB_SUBTREES,1,-1 DO WHILE(MUMPS_283( & 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_555 END MODULE SMUMPS_LOAD mumps-4.10.0.dfsg/src/smumps_part7.F0000644000175300017530000007562311562233065017460 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE SMUMPS_635(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(40), MPG KEEP(19)=0 RETURN END SUBROUTINE SMUMPS_635 SUBROUTINE SMUMPS_634(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_634 SUBROUTINE SMUMPS_637(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) id NULLIFY(id%root%QR_TAU) RETURN END SUBROUTINE SMUMPS_637 SUBROUTINE SMUMPS_636(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 RETURN END SUBROUTINE SMUMPS_636 SUBROUTINE SMUMPS_146( MYID, root, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP) IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' TYPE ( SMUMPS_ROOT_STRUC ) :: root INTEGER N, IROOT, COMM, LIW, MYID, IFREE INTEGER(8) :: LA INTEGER(8) :: LWK REAL WK( LWK ) INTEGER KEEP(500) REAL DKEEP(30) 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 ) INTEGER IOLDPS INTEGER(8) :: IAPOS 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_320( 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_320( 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 (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in SMUMPS_146:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL SMUMPS_763(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_768( & 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_146 SUBROUTINE SMUMPS_556( & 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_556 SUBROUTINE SMUMPS_550(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_550 SUBROUTINE SMUMPS_547( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL) IMPLICIT NONE INTEGER N,NZ,NCMP,LW,IWFR,IERROR INTEGER ICNTL(40),KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN(NZ),ICN(NZ),IW(LW),PIV(N),IPE(N+1) INTEGER LEN(N),IQ(N),FLAG(N),ICMP(N) INTEGER MP,N11,N22,NDUP INTEGER I,K,J,N1,LAST,K1,K2,L 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 K=1,NZ I = IRN(K) J = ICN(K) I = ICMP(I) J = ICMP(J) 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 IPE(J) = IPE(J) + 1 ENDIF ENDIF ENDDO IQ(1) = 1 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,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO DO K=1,LAST IW(K) = 0 ENDDO IWFR = LAST + 1 DO K=1,NZ I = IRN(K) J = ICN(K) 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 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO NDUP = 0 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1 IF (K1.GT.K2) THEN LEN(I) = 0 IQ(I) = 0 ELSE DO K=K1,K2 J = -IW(K) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1 IW(L) = 0 IW(K) = 0 ELSE IW(L) = I IW(K) = J FLAG(J) = I ENDIF ENDDO 250 IQ(I) = IQ(I) - IPE(I) IF (NDUP.EQ.0) LEN(I) = IQ(I) ENDIF ENDDO IF (NDUP.NE.0) THEN IWFR = 1 DO I=1,NCMP K1 = IPE(I) IF (IQ(I).EQ.0) THEN LEN(I) = 0 IPE(I) = IWFR CYCLE ENDIF K2 = K1 + IQ(I) - 1 L = IWFR IPE(I) = IWFR DO K=K1,K2 IF (IW(K).NE.0) THEN IW(IWFR) = IW(K) IWFR = IWFR + 1 ENDIF ENDDO LEN(I) = IWFR - L ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + LEN(NCMP) IWFR = IPE(NCMP+1) RETURN END SUBROUTINE SMUMPS_547 SUBROUTINE SMUMPS_551( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER N, NE, ICNTL(10), INFO(10),LSC INTEGER CPERM(N),PIV_OUT(N),IP(N+1),IRN(NE), DIAG(N) REAL SCALING(LSC),WEIGHT(N+2) INTEGER MARKED(N),FLAG(N) INTEGER NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER I,CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT,BEST_BEG INTEGER L1,L2,PTR_SET1,PTR_SET2,TUP,T22 REAL BEST_SCORE,CUR_VAL,TMP,VAL REAL INITSCORE, SMUMPS_739, & SMUMPS_740, SMUMPS_741 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 = IP(CUR_EL+1)-IP(CUR_EL) L2 = 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_741( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & SMUMPS_739(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 = IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH) L2 = 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_741( & 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_739(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_739(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = SMUMPS_740(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_739(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = SMUMPS_740(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_551 FUNCTION SMUMPS_739(A,B,T) IMPLICIT NONE REAL SMUMPS_739 REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN SMUMPS_739 = A+B ELSE SMUMPS_739 = A*B ENDIF END FUNCTION SMUMPS_739 FUNCTION SMUMPS_740(A,B,T) IMPLICIT NONE REAL SMUMPS_740 REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN SMUMPS_740 = A-B ELSE SMUMPS_740 = A/B ENDIF END FUNCTION SMUMPS_740 FUNCTION SMUMPS_741(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE REAL SMUMPS_741 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_741 = 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_741 = real(L1+L2-2) SMUMPS_741 = -(SMUMPS_741**2)/2.0E0 ELSE IF(MERGE .EQ. 1) THEN SMUMPS_741 = - real(L1+L2-4) * real(L1-2) ELSE IF(MERGE .EQ. 2) THEN SMUMPS_741 = - real(L1+L2-4) * real(L2-2) ELSE SMUMPS_741 = - real(L1-2) * real(L2-2) ENDIF ELSE SMUMPS_741 = VAL ENDIF RETURN END FUNCTION SUBROUTINE SMUMPS_622(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_622 SUBROUTINE SMUMPS_623 & (NA,N,NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, MedDens, NBQD, AvgDens, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN) :: NA,N,NZ,LW INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: ICNTL(40), SYM INTEGER, INTENT(INOUT) :: IFLAG INTEGER, INTENT(OUT) :: IERROR,NRORM,NIORM,IWFR INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, INTENT(OUT) :: LEN(N), IPE(N+1) INTEGER, INTENT(OUT) :: symmetry, & MedDens, NBQD, AvgDens INTEGER, INTENT(OUT) :: FLAG(N), IW(LW), IQ(N) INTEGER MP, MPG INTEGER I,K,J,N1,LAST,NDUP,K1,K2,L INTEGER NBERR, THRESH, IAO INTEGER NZOFFA, NDIAGA REAL RSYM INTRINSIC nint 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 MP = ICNTL(2) MPG= ICNTL(3) NIORM = 3*N NDIAGA = 0 IERROR = 0 IPE(1:N+1) = 0 DO K=1,NZ I = IRN(K) J = ICN(K) 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 IPE(J) = IPE(J) + 1 NIORM = NIORM + 1 ELSE NDIAGA = NDIAGA + 1 ENDIF ENDIF ENDDO NZOFFA = NIORM - 3*N 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 K=1,NZ I = IRN(K) J = ICN(K) 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(K,10).GT.3 .OR. mod(K,10).EQ.0 .OR. & (10.LE.K .AND. K.LE.20)) THEN WRITE (MP,'(I8,A,I8,A,I8,A)') & K,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K,10).EQ.1) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'st entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.2) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.3) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2*N IQ(1) = 1 N1 = N - 1 IF (N1.GT.0) THEN DO 110 I=1,N1 IQ(I+1) = IPE(I) + IQ(I) 110 CONTINUE 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 DO 200 K=1,NZ I = IRN(K) J = ICN(K) 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 IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF 200 CONTINUE NDUP = 0 DO 260 I=1,N K1 = IPE(I) K2 = IQ(I) -1 IF (K1.GT.K2) THEN LEN(I) = 0 IQ(I) = 0 ELSE DO 240 K=K1,K2 J = -IW(K) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1 IW(L) = 0 IW(K) = 0 ELSE IW(L) = I IW(K) = J FLAG(J) = I ENDIF 240 CONTINUE 250 IQ(I) = IQ(I) - IPE(I) IF (NDUP.EQ.0) LEN(I) = IQ(I) ENDIF 260 CONTINUE IF (NDUP.NE.0) THEN IWFR = 1 DO 280 I=1,N IF (IQ(I).EQ.0) THEN LEN(I) = 0 IPE(I) = IWFR GOTO 280 ENDIF K1 = IPE(I) K2 = K1 + IQ(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K=K1,K2 IF (IW(K).NE.0) THEN IW(IWFR) = IW(K) IWFR = IWFR + 1 ENDIF 270 CONTINUE LEN(I) = IWFR - L 280 CONTINUE ENDIF IPE(N+1) = IPE(N) + LEN(N) IWFR = IPE(N+1) IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2*NZOFFA - (IWFR-1))/ & real(NZOFFA+NDIAGA) symmetry = nint (100.0E0*RSYM) IF (MPG .GT. 0) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ELSE symmetry = 100 ENDIF AvgDens = nint(real(IWFR-1)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN IQ(1:N) = 0 DO I= 1, N K = max(LEN(I),1) IQ(K) = IQ(K) + 1 IF (K.GT.THRESH) NBQD = NBQD+1 ENDDO K = 0 MedDens = 0 DO WHILE (K .LT. (N/2)) MedDens = MedDens + 1 K = K+IQ(MedDens) ENDDO ELSE MedDens = AvgDens ENDIF IF (MPG .GT. 0) & write(MPG,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE SMUMPS_623 SUBROUTINE SMUMPS_549(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_549 SUBROUTINE SMUMPS_548(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_548 mumps-4.10.0.dfsg/src/cmumps_part2.F0000644000175300017530000074362111562233067017435 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE CMUMPS_152(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_729( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) ) IF (KEEP(216).eq.3) THEN SIZFR_BLOCK_EFF=SIZFR_BLOCK ELSE CALL CMUMPS_628( 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 ENDIF MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL CMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLU) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 IPOSSHIFT = IWPOSCB + KEEP(IXSZ) SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_729( 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) LRLUS = LRLUS + SIZFR_BLOCK_EFF CALL CMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLU) END IF RETURN END SUBROUTINE CMUMPS_152 SUBROUTINE CMUMPS_144( 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) USE CMUMPS_OOC 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), & PTRARW(LPTRAR), PTRAIW(LPTRAR), & ND( KEEP(28) ), FRERE( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) 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(max(1,KEEP(13))) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, & NBTLKJ, IBEG_BLOCK INTEGER(8) :: POSELT INTEGER NASS, NEL1, IEND, IOLDPS, dummy, allocok LOGICAL LASTBL REAL UUTEMP INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INCLUDE 'mumps_headers.h' EXTERNAL CMUMPS_224, CMUMPS_233, & CMUMPS_225, CMUMPS_232, & CMUMPS_294, & CMUMPS_44 LOGICAL STATICMODE REAL SEUIL_LOC 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 IBEG_BLOCK=1 dummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5),NASS ) ENDIF NBTLKJ = NBOLKJ ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, & ' integers' IFLAG = -13 IERROR =NASS GO TO 490 END IF IF (KEEP(201).EQ.1) THEN CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_U 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 50 CONTINUE IBEGKJI = IBEG_BLOCK CALL CMUMPS_224(NFRONT,NASS,IBEGKJI, NASS, IPIV, & 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) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ENDIF IF (INOPV.GE.1) THEN LASTBL = (INOPV.EQ.1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL CMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, NFRONT, & IBEGKJI, IEND, IPIV, NASS,LASTBL, dummy, & & 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, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (INOPV.EQ.1) GO TO 500 IF (INOPV.EQ.2) THEN CALL CMUMPS_233(IBEG_BLOCK,NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP(IXSZ)) GOTO 50 ENDIF NPVW = NPVW + 1 IF (NASS.LE.1) THEN IFINB = -1 ELSE CALL CMUMPS_225(IBEG_BLOCK, & NFRONT, NASS, N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),KEEP(IXSZ)) ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 50 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN LASTBL = (IFINB.EQ.-1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL CMUMPS_294(COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, NFRONT, & IBEGKJI, IEND, IPIV, NASS, LASTBL, dummy, & & 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, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (IFINB.EQ.(-1)) GOTO 500 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV CALL CMUMPS_232(A,LA, & NFRONT,NPIV,NASS,POSELT,NBTLKJ) IF (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV TYPEFile = TYPEF_BOTH_LU LAST_CALL= .FALSE. CALL CMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG<0) RETURN ENDIF GO TO 50 490 CONTINUE CALL CMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE DEALLOCATE( IPIV ) IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) TYPEFile = TYPEF_BOTH_LU LAST_CALL = .TRUE. CALL CMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG<0) RETURN CALL CMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE CMUMPS_144 SUBROUTINE CMUMPS_176( 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, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE CMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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(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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX DBLARR( max(1,KEEP(13)) ) 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 INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_73(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'CMUMPS_73' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL CMUMPS_270( 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, 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_275(PROCNODE_STEPS(STEP(IN)),SLAVEF) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL CMUMPS_74(IN, NELIM_SENT, & PDEST, COMM, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'CMUMPS_73' CALL MUMPS_ABORT() endif ELSE CALL CMUMPS_271( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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 CALL CMUMPS_626( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL CMUMPS_152( .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_176 SUBROUTINE CMUMPS_268(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, NBPROCFILS, & IPOOL, LPOOL, LEAF, KEEP,KEEP8, 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) 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 NBPROCFILS( 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_330 EXTERNAL MUMPS_330 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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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 + 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 ( ( KEEP(48).NE. 0 ).AND.(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_330(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_507(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE CMUMPS_268 SUBROUTINE CMUMPS_242(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF) USE CMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST 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_62( DATA(1), DEST, TAG, & COMMW, IERR ) ELSE WRITE(*,*) 'Error : bad argument to CMUMPS_242' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE CMUMPS_242 SUBROUTINE CMUMPS_44( MYID, SLAVEF, COMM ) INTEGER MYID, SLAVEF, COMM INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) CALL CMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF ) RETURN END SUBROUTINE CMUMPS_44 SUBROUTINE CMUMPS_464( K34, K35, K16, K10 ) IMPLICIT NONE INTEGER, INTENT(OUT) :: K34, K35, K10, K16 INTEGER SIZE_INT, SIZE_REAL_OR_DOUBLE INTEGER I(2) REAL R(2) 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_464 SUBROUTINE CMUMPS_20( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP) IMPLICIT NONE REAL DKEEP(30) REAL CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(40), KEEP(500), SYM, PAR, NSLAVES INTEGER INFO(40), INFOG(40) INTEGER(8) KEEP8(150) INTEGER LWK_USER C Let $A_{preproc}$ be the preprocessed matrix to be factored (see 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:30) = 0.0E0 KEEP( 50 ) = SYM IF (SYM.EQ.1) THEN KEEP(50) = 2 ENDIF IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 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 KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN KEEP(46) = 1 END IF ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 ICNTL(5) = 0 IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF ICNTL(7) = 7 ICNTL(8) = 77 ICNTL(9) = 1 ICNTL(10) = 0 ICNTL(11) = 0 IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF ICNTL(13) = 0 IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ELSE IF (NSLAVES .GT. 4) THEN ICNTL(14) = 30 ELSE ICNTL(14) = 20 END IF ICNTL(15) = 0 ICNTL(16) = 0 ICNTL(17) = 0 ICNTL(18) = 0 ICNTL(19) = 0 ICNTL(20) = 0 ICNTL(21) = 0 ICNTL(22) = 0 ICNTL(23) = 0 ICNTL(24) = 0 ICNTL(27) = -8 ICNTL(28) = 1 ICNTL(29) = 0 ICNTL(39) = 1 ICNTL(40) = 0 KEEP(12) = 0 KEEP(11) = 2147483646 KEEP(24) = 18 KEEP(68) = 0 KEEP(36) = 1 KEEP(1) = 8 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 IF (NSLAVES.GE.128) KEEP(62)=200 IF (NSLAVES.GE.128) KEEP(9)=800 IF (NSLAVES.GE.256) KEEP(9)=900 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 48 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 100 IF (NSLAVES.GE.128) KEEP(62)=150 IF (NSLAVES.GE.64) KEEP(9)=800 IF (NSLAVES.GE.128) KEEP(9)=900 END IF KEEP(63) = 60 KEEP(48) = 5 KEEP(17) = 0 CALL CMUMPS_464( KEEP(34), KEEP(35), & KEEP(16), KEEP(10) ) #if defined(SP_) KEEP( 51 ) = 70 #else KEEP( 51 ) = 48 #endif 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) = 10 KEEP(69) = 4 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 30 KEEP(79) = 0 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) = 5 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 #else KEEP(99)=4 #endif KEEP(100)=0 KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 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 IF(NSLAVES.LE.8)THEN KEEP(238)=12 ELSE KEEP(238)=7 ENDIF KEEP(234)= 1 DKEEP(3)=-5.0E0 KEEP(242) = 1 KEEP(250) = 1 RETURN END SUBROUTINE CMUMPS_20 SUBROUTINE CMUMPS_786(id, LP) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN IF (LP.GT.0) & write(LP,*) 'Warning KEEP(72) = 1 !!!!!!!!!! ' 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 ELSE IF (id%KEEP(72)==2) THEN IF (LP.GT.0) & write(LP,*)' OOC setting to reduce stack memory', & ' KEEP(72)=', id%KEEP(72) id%KEEP(85)=2 id%KEEP(85)=-10000 id%KEEP(62) = 10 id%KEEP(210) = 1 id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 id%KEEP(102) = 110 id%KEEP(213) = 121 END IF RETURN END SUBROUTINE CMUMPS_786 SUBROUTINE CMUMPS_195(N, NZ, IRN, ICN, LIW, IKEEP, PTRAR, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N,NZ,LIW,IORD,SIZE_SCHUR, NSLAVES INTEGER PTRAR(N,4), NFSIZ(N), FILS(N), FRERE(N) INTEGER IKEEP(N,3) INTEGER LISTVAR_SCHUR(SIZE_SCHUR) INTEGER INFO(40), ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) TYPE (CMUMPS_STRUC) :: id INTEGER IRN(NZ), ICN(NZ) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER IERR INTEGER K,I,L1,L2,IWFR,NCMPA,LLIW, IN, IFSON INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER MedDens, NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: HEAD INTEGER NUMFLAG INTEGER OPT_METIS_SIZE INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS 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 EXTERNAL MUMPS_197, CMUMPS_198, & CMUMPS_199, CMUMPS_351, & CMUMPS_557, CMUMPS_201 #if defined(OLDDFS) EXTERNAL CMUMPS_200 #endif EXTERNAL CMUMPS_623 EXTERNAL CMUMPS_547, CMUMPS_550, & CMUMPS_556 ALLOCATE( IW ( LIW ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW RETURN ENDIF LLIW = LIW - 2*N - 1 L1 = LLIW + 1 L2 = L1 + N LP = ICNTL(1) MP = ICNTL(3) PROK = (MP.GT.0) 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, NZ, LIW, INFO(1) K = min0(10,NZ) IF (LDIAG.EQ.4) K = NZ IF (K.GT.0) WRITE (MP,99998) (IRN(I),ICN(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 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) 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 CALL CMUMPS_623(N,NCMP,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), MedDens, NBQD, AvgDens, & LISTVAR_SCHUR, SIZE_SCHUR, & FRERE,FILS) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif CALL CMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), MedDens, NBQD, AvgDens) #if defined(metis) || defined(parmetis) 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 CMUMPS_701( N, KEEP(50), NSLAVES, IORD, & symmetry, MedDens, 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_195 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_195 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_556( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) ENDIF IF ( IORD .NE. 1 ) THEN IF(COMPRESS .GE. 1) THEN CALL CMUMPS_547( & N,NZ, IRN, ICN, PIV, & NCMP, IW(1), LLIW, IW(L2),PTRAR(1,2),PTRAR, & IW(L1), FILS, IWFR, & IERROR, KEEP,KEEP8, ICNTL) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 DEALLOCATE (IW) RETURN 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 K=1,NZ J = ICN(K) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(K) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N RETURN 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 (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' CALL CMUMPS_351 & (N,NZ,IRN, ICN, IW(1), LLIW, IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & MedDens, NBQD, AvgDens) 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 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 ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_162(N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & 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 IF(COMPRESS .EQ. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO CALL MUMPS_PORDF_WND(NCMP, IWFR-1, IW(L2), IW, & IW(L1), NCMPA, N) CALL CMUMPS_548(NCMP,IW(L2),IW(L1),FILS) CALL CMUMPS_549(NCMP,IW(L2),IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ELSE CALL MUMPS_PORDF(NCMP, IWFR-1, IW(L2), IW(1), & IW(L1), NCMPA) ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 RETURN ENDIF #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH(NCMP, LLIW, IW(L2), IWFR, & PTRAR(1,2), IW(1), IW(L1), IKEEP, & IKEEP(1,2), NCMPA) IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out SCTOCH, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 3 RETURN ENDIF IF (COMPRESS .EQ. 1) THEN CALL CMUMPS_548(NCMP,IW(L2),IW(L1),FILS) CALL CMUMPS_549(NCMP,IW(L2),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( HEAD ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 RETURN ENDIF IF(COMPRESS .GE. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO ELSE IW(L1) = -1 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_337(NCMP, NBBUCK, LLIW, IW(L2), & IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_560(NCMP, NBBUCK, LLIW, IW(L2), & IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD, & NFSIZ, FRERE) ENDIF DEALLOCATE(HEAD) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( HEAD ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N RETURN ENDIF THRESH = 1 IVersion = 2 IF(COMPRESS .EQ. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IW(L1) = -1 TOTEL = N ENDIF CALL MUMPS_421(TOTEL,IVersion, THRESH, HEAD, & NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), & IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3)) DEALLOCATE(HEAD) ELSE CALL MUMPS_197(NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL CMUMPS_550(N,NCMP,KEEP(94),KEEP(93), & PIV,IKEEP(1,1),IKEEP(1,2)) COMPRESS = -1 ENDIF ENDIF #if defined(metis) || defined(parmetis) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS ' ENDIF 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 RETURN ENDIF OPTIONS_METIS(1) = 0 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FILS(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FILS(I) = 1 ENDDO CALL METIS_NODEWND(NCMP, IW(L2), IW(1),FILS, & NUMFLAG, OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) ELSE CALL METIS_NODEND(NCMP, IW(L2), IW(1), NUMFLAG, & OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) ENDIF DEALLOCATE (OPTIONS_METIS) IF ( COMPRESS_SCHUR ) THEN CALL CMUMPS_622( & N, NCMP, IKEEP(1,1),IKEEP(1,2), & LISTVAR_SCHUR, SIZE_SCHUR, FILS) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL CMUMPS_550(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) THEN IF ( COMPRESS .EQ. -1 ) THEN CALL CMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & MedDens, NBQD, AvgDens) INFO(8) = symmetry ENDIF COMPRESS = 0 ALLOCATE( HEAD ( 2*N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 2*N RETURN 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 =.TRUE. CALL MUMPS_422(THRESH, HEAD, & N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW, & IW(L1), HEAD(N+1), & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & IKEEP(1,1), LISTVAR_SCHUR, ITEMP, AGG6) DEALLOCATE(HEAD) ELSE CALL CMUMPS_198(N, NZ, IRN, ICN, IKEEP, IW(1), & LLIW, IW(L2), & PTRAR(1,2), IW(L1), IWFR, & INFO(1),INFO(2), KEEP(11), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 CALL CMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & PTRAR, NCMPA, ITEMP) ELSE CALL CMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & PTRAR, NCMPA, SIZE_SCHUR) 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_200 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else CALL CMUMPS_557 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, PTRAR, INFO(6), FILS, FRERE, & PTRAR(1,3), NEMIN, PTRAR(1,4), KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1) #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_201(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_209( 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_510(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 IF ( huge(KEEP8(79)) / K79REF + 1_8 .GE. int(NSLAVES,8) ) THEN KEEP8(79)=huge(KEEP8(79)) ELSE KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF 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_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG,INFO(1),INFO(2)) IF (INFO(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) & .AND. (KEEP(60).EQ.0) IF (SPLITROOT) THEN CALL CMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG,INFO(1),INFO(2)) IF (INFO(1).LT.0) RETURN 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,99986) (PTRAR(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99985) (PTRAR(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99984) (PTRAR(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 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) GOTO 90 90 CONTINUE DEALLOCATE(IW) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NZ 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)=', 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)) 99986 FORMAT ('PTRAR(.,1)=', 10I6/(12X, 10I6)) 99985 FORMAT ('PTRAR(.,2)=', 10I6/(12X, 10I6)) 99984 FORMAT ('PTRAR(.,3)=', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE CMUMPS_195 SUBROUTINE CMUMPS_199(N,IPE,IW, LW, IWFR, IPS, IPV, NV, FLAG, & NCMPA, SIZE_SCHUR) INTEGER N,LW,IWFR,NCMPA,SIZE_SCHUR INTEGER FLAG(N) INTEGER IPS(N), IPV(N) INTEGER IW(LW), NV(N), IPE(N) INTEGER I,J,ML,MS,ME,IP,MINJS,IE,KDUMMY,JP INTEGER LN,JP1,JS,LWFR,JP2,JE 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) GO TO 60 LN = IW(JP) DO 50 JP1=1,LN JP = JP + 1 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 - JP1 CALL CMUMPS_194(N, IPE, IW, IP-1, 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 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min0(MINJS,IPS(JS)+0) IWFR = IWFR + 1 50 CONTINUE 60 IPE(IE) = -ME 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 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = IWFR - IP IPE(ME) = IP IWFR = IWFR + 1 100 CONTINUE IF (SIZE_SCHUR == 0) RETURN 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) GO TO 160 LN = IW(JP) 160 IPE(IE) = -IPV(N-SIZE_SCHUR+1) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = -IPV(N-SIZE_SCHUR+1) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0 NV(ME) = SIZE_SCHUR RETURN END SUBROUTINE CMUMPS_199 SUBROUTINE CMUMPS_198(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, IOVFLO, MP) INTEGER N,NZ,LW,IWFR,IFLAG,IERROR INTEGER PERM(N) INTEGER IQ(N) INTEGER IRN(NZ), ICN(NZ) INTEGER IPE(N), IW(LW), FLAG(N) INTEGER MP INTEGER IOVFLO INTEGER I,J,K,LBIG,L,ID,IN,LEN,JDUMMY,K1,K2 IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1,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 LBIG = 0 DO 100 I=1,N L = IQ(I) LBIG = max0(L,LBIG) IWFR = IWFR + L IPE(I) = IWFR - 1 100 CONTINUE DO 140 K=1,NZ I = -IW(K) IF (I.LE.0) GO TO 140 L = K IW(K) = 0 DO 130 ID=1,NZ J = ICN(L) IF (PERM(I).LT.PERM(J)) GO TO 110 L = IPE(J) IPE(J) = L - 1 IN = IW(L) IW(L) = I GO TO 120 110 L = IPE(I) IPE(I) = L - 1 IN = IW(L) IW(L) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1 L = K + N IWFR = L + 1 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(L) = IW(K) K = K - 1 L = L - 1 150 CONTINUE 160 IPE(J) = L L = L - 1 170 CONTINUE IF (LBIG.GE.IOVFLO) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0 180 CONTINUE GO TO 230 190 IWFR = 1 DO 220 I=1,N K1 = IPE(I) + 1 K2 = IPE(I) + IQ(I) IF (K1.LE.K2) GO TO 200 IPE(I) = 0 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = IWFR - K - 1 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM CMUMPS_198 ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE CMUMPS_198 SUBROUTINE CMUMPS_194(N, IPE, IW, LW, IWFR,NCMPA) INTEGER N,LW,IWFR,NCMPA INTEGER IPE(N) INTEGER IW(LW) INTEGER I,K1,LWFR,IR,K,K2 NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0) GO TO 10 IPE(I) = IW(K1) IW(K1) = -I 10 CONTINUE IWFR = 1 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) = IPE(I) IPE(I) = IWFR K1 = K + 1 K2 = K + IW(IWFR) IWFR = IWFR + 1 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1 40 CONTINUE 50 LWFR = K2 + 1 60 CONTINUE 70 RETURN END SUBROUTINE CMUMPS_194 #if defined(OLDDFS) SUBROUTINE CMUMPS_200(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_200 #else SUBROUTINE CMUMPS_557(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 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 #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 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 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 #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(20000)* & dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) & ) & / & ( dble(NV(DADI)+NODE(I))* & dble(NV(DADI)+NODE(I)) ) ACCU = ACCU + dble(CUMUL(I) ) AMALG_TO_father_OK = ( (NODE(I).LE.NEMIN).OR. & (NODE(DADI).LE.NEMIN) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( & ( dble(2*(NODE(I)))* & dble((NV(DADI)-NV(I)+NODE(I))) & ) .LT. & ( dble(NV(DADI)+NODE(I))* & dble(NV(DADI)+NODE(I))*dble(NEMIN)/dble(100) & ) & ) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU .LE. dble(NEMIN)*dble(100) ) & ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_511(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_511(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_511(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF(FLOPS_APRES .GT. FLOPS_AVANT) 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 AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) 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_557 #endif SUBROUTINE CMUMPS_201(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 IF(NFR .NE. NELIM) 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_201 SUBROUTINE CMUMPS_348( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(INOUT) :: 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_348 SUBROUTINE CMUMPS_203( N, NZ, MTRANS, PERM, & id, ICNTL, INFO) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER N, NZ, LIWG INTEGER PERM(N) INTEGER MTRANS INTEGER ICNTL(40), INFO(40) INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW REAL, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER LS2,LSC INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) REAL CNTL64(10) INTEGER LDW, LDWMIN INTEGER MPRINT,LP, MP, IPIW, LIW, LIWMIN INTEGER JPERM INTEGER NUMNZ, I, J, JPOS, K, NZREAL INTEGER PLENR, IP, IRNW,RSPOS,CSPOS LOGICAL PROK, IDENT, DUPPLI INTEGER NZTOT, K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG 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) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = (MPRINT.GT.0) 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 .EQ. 2) THEN NZTOT = 2*NZ+N ELSE NZTOT = NZ ENDIF ZERODIAG => id%IS1(N+1:2*N) STR_KER => id%IS1(2*N+1:3*N) CALL CMUMPS_448(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 DIAGIONAL' 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 IP = IRNW + NZTOT PLENR = IP + N + 1 IPIW = PLENR IF (MTRANSLOC.EQ.1) LIWMIN = 5*N IF (MTRANSLOC.EQ.2) LIWMIN = 4*N IF (MTRANSLOC.EQ.3) LIWMIN = 10*N + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 5*N IF (MTRANSLOC.EQ.5) LIWMIN = 5*N IF (MTRANSLOC.EQ.6) LIWMIN = 5*N + NZTOT LIW = LIWMIN LIWG = LIW + (NZTOT + N + 1) ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) GOTO 410 IF (MTRANSLOC.EQ.1) THEN LDWMIN = N+3 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max(N+NZTOT,N+3) IF (MTRANSLOC.EQ.3) LDWMIN = max(NZTOT+1,N+3) IF (MTRANSLOC.EQ.4) LDWMIN = 2*N + max(NZTOT,N+3) IF (MTRANSLOC.EQ.5) LDWMIN = 3*N + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4*N + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N IF (allocok .GT. 0 ) GOTO 430 NZREAL = 0 DO 5 J=1,N IW(PLENR+J-1) = 0 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 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 NZREAL = NZREAL + 1 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 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 NZREAL = NZREAL + 1 IF(I .NE. J) THEN IW(PLENR+I-1) = IW(PLENR+I-1) + 1 NZREAL = NZREAL + 1 ELSE IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = K 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 IW(PLENR+I-1) = IW(PLENR+I-1) + 1 NZREAL = NZREAL + 1 ENDIF ENDDO ENDIF ENDIF IW(IP) = 1 DO 20 J=1,N IW(IP+J) = IW(IP+J-1)+IW(PLENR+J-1) 20 CONTINUE DO 25 J=1, N IW(PLENR+J-1 ) = IW(IP+J-1 ) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO 30 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I IW(PLENR+J-1) = IW(PLENR+J-1) + 1 ENDIF 30 CONTINUE ELSE IF ( .not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO 35 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I S2(JPOS) = abs(id%A(K)) IW(PLENR+J-1) = IW(PLENR+J-1) + 1 ENDIF 35 CONTINUE 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I IW(PLENR+J-1) = IW(PLENR+J-1) + 1 IF(I.NE.J) THEN JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = J IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF K = 1 THEMIN = ZERO DO IF(THEMIN .NE. ZERO) EXIT THEMIN = abs(id%A(K)) K = K+1 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I S2(JPOS) = abs(id%A(K)) IW(PLENR+J-1) = IW(PLENR+J-1) + 1 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 JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = J S2(JPOS) = abs(id%A(K)) IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = I S2(JPOS) = ZERO IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDDO CNTL64(2) = (log(THEMAX/THEMIN))*(real(N)) & - log(THEMIN) + ONE ENDIF ENDIF DUPPLI = .FALSE. I = NZREAL FLAG => id%IS1(3*N+1:4*N) IF(MTRANSLOC.NE.1) THEN CALL CMUMPS_563(N,NZREAL,IW(IP),IW(IRNW),S2, & PERM,FLAG(1)) ELSE CALL CMUMPS_562(N,NZREAL,IW(IP),IW(IRNW), & PERM,FLAG(1)) ENDIF IF(NZREAL .NE. I) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1 LDW = 1 ENDIF CALL CMUMPS_559(MTRANSLOC ,N, N, NZREAL, & IW(IP), IW(IRNW), S2(1), LS2, & NUMNZ, PERM, LIW, IW(IPIW), LDW, S2(LS2+1), & ICNTL64, CNTL64, INFO64) 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(PLENR+JPERM-1) = 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(PLENR+J-1) 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_203' 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_203' 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 id%ROWSCA(J) = exp(S2(RSPOS+J)) 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+J)) IF(id%COLSCA(J) .EQ. ZERO) THEN id%COLSCA(J) = ONE ENDIF ELSE id%COLSCA(IW(PLENR+J-1))= exp(S2(CSPOS+J)) IF(id%COLSCA(IW(PLENR+J-1)) .EQ. ZERO) THEN id%COLSCA(IW(PLENR+J-1)) = 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_203' 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_203' 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)+S2(CSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO S2(CSPOS+J)= ZERO ENDIF ENDDO DO J=1,N IF(PERM(J) .GT. 0) THEN id%ROWSCA(J) = & exp((S2(RSPOS+J)+S2(CSPOS+J))/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 J = IW(IP+I-1),IW(IP+I) - 1 IF ( PERM( IW( IRNW+J-1) ) > 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_551( & N, NZREAL, IW(IP), 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_203' 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_203' WRITE (LP,'(A,I9)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -5 INFO(2) = LIWG GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_203' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 INFO(2) = LDW 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) RETURN END SUBROUTINE CMUMPS_203 SUBROUTINE CMUMPS_100 &( 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) 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_100 SUBROUTINE CMUMPS_97 & ( 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) MAX_DEPTH=1 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) 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_313 & ( 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_97 RECURSIVE SUBROUTINE CMUMPS_313 & ( 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_50, & MUMPS_52 EXTERNAL MUMPS_50, & MUMPS_52 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_50 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB) NSLAVESMAX = MUMPS_52 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB) 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 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 ) CALL CMUMPS_313 & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG ) IF (.NOT. SPLITROOT) THEN CALL CMUMPS_313 & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG ) ENDIF RETURN END SUBROUTINE CMUMPS_313 SUBROUTINE CMUMPS_351 & (N,NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, MedDens, NBQD, AvgDens) INTEGER N,NZ,LW,IFLAG,IERROR,NRORM,NIORM,IWFR INTEGER symmetry, SYM INTEGER MedDens, NBQD, AvgDens INTEGER ICNTL(40) INTEGER IRN(NZ), ICN(NZ) INTEGER LEN(N) INTEGER IPE(N+1) INTEGER FLAG(N), IW(LW) INTEGER IQ(N) INTEGER MP, MPG INTEGER I,K,J,N1,LAST,NDUP,K1,K2,L INTEGER NBERR, THRESH INTEGER NZOFFA, NDIAGA REAL RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NIORM = 3*N NDIAGA = 0 IERROR = 0 DO 10 I=1,N IPE(I) = 0 10 CONTINUE DO 50 K=1,NZ I = IRN(K) J = ICN(K) 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 IPE(J) = IPE(J) + 1 NIORM = NIORM + 1 ELSE NDIAGA = NDIAGA + 1 ENDIF ENDIF 50 CONTINUE NZOFFA = NIORM - 3*N 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 K=1,NZ I = IRN(K) J = ICN(K) 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(K,10).GT.3 .OR. mod(K,10).EQ.0 .OR. & (10.LE.K .AND. K.LE.20)) THEN WRITE (MP,'(I8,A,I8,A,I8,A)') & K,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K,10).EQ.1) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'st entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.2) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.3) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2*N IQ(1) = 1 N1 = N - 1 IF (N1.GT.0) THEN DO 110 I=1,N1 IQ(I+1) = IPE(I) + IQ(I) 110 CONTINUE 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 DO 200 K=1,NZ I = IRN(K) J = ICN(K) 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 200 CONTINUE NDUP = 0 DO 260 I=1,N K1 = IPE(I) K2 = IQ(I) -1 IF (K1.GT.K2) THEN LEN(I) = 0 IQ(I) = 0 ELSE DO 240 K=K1,K2 J = -IW(K) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1 IW(L) = 0 IW(K) = 0 ELSE IW(L) = I IW(K) = J FLAG(J) = I ENDIF 240 CONTINUE 250 IQ(I) = IQ(I) - IPE(I) IF (NDUP.EQ.0) LEN(I) = IQ(I) ENDIF 260 CONTINUE IF (NDUP.NE.0) THEN IWFR = 1 DO 280 I=1,N IF (IQ(I).EQ.0) THEN LEN(I) = 0 IPE(I) = IWFR GOTO 280 ENDIF K1 = IPE(I) K2 = K1 + IQ(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K=K1,K2 IF (IW(K).NE.0) THEN IW(IWFR) = IW(K) IWFR = IWFR + 1 ENDIF 270 CONTINUE LEN(I) = IWFR - L 280 CONTINUE ENDIF IPE(N+1) = IPE(N) + LEN(N) IWFR = IPE(N+1) IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2*NZOFFA - (IWFR-1))/ & real(NZOFFA+NDIAGA) symmetry = nint (100.0E0*RSYM) IF (MPG .GT. 0) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ELSE symmetry = 100 ENDIF AvgDens = nint(real(IWFR-1)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN IQ(1:N) = 0 DO I= 1, N K = max(LEN(I),1) IQ(K) = IQ(K) + 1 IF (K.GT.THRESH) NBQD = NBQD+1 ENDDO K = 0 MedDens = 0 DO WHILE (K .LT. (N/2)) MedDens = MedDens + 1 K = K+IQ(MedDens) ENDDO ELSE MedDens = AvgDens ENDIF IF (MPG .GT. 0) & write(MPG,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE CMUMPS_351 SUBROUTINE CMUMPS_701(N, SYM, NPROCS, IORD, & symmetry,MedDens, NBQD, AvgDens, & PROK, MP) IMPLICIT NONE INTEGER, intent(in) :: N, NPROCS, SYM INTEGER, intent(in) :: symmetry,MedDens, 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) 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 (NBQD.GE.MedDens*NPROCS) THEN IORD = 6 RETURN ENDIF #if defined(metis) || defined(parmetis) 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 (NBQD.GE.MedDens*NPROCS) THEN IORD = 6 RETURN ENDIF #if defined(metis) || defined(parmetis) 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 CMUMPS_701 SUBROUTINE CMUMPS_510 & (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_510 SUBROUTINE CMUMPS_559(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & ICNTL,CNTL,INFO) IMPLICIT NONE INTEGER NICNTL, NCNTL, NINFO PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER JOB,M,N,NE,NUM,LIW,LDW INTEGER IP(N+1),IRN(NE),PERM(M),IW(LIW) INTEGER ICNTL(NICNTL),INFO(NINFO) INTEGER LA REAL A(LA) REAL DW(LDW),CNTL(NCNTL) INTEGER I,J,K,WARN1,WARN2,WARN4 REAL FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0E+00,ONE=1.0E+0) EXTERNAL CMUMPS_457,CMUMPS_444,CMUMPS_451, & CMUMPS_452,CMUMPS_454 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 INFO(2) = NE IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = 4*N + M IF (JOB.EQ.2) K = 2*N + 2*M IF (JOB.EQ.3) K = 8*N + 2*M + NE IF (JOB.EQ.4) K = 3*N + 2*M IF (JOB.EQ.5) K = 3*N + 2*M IF (JOB.EQ.6) K = 3*N + 2*M + NE IF (LIW.LT.K) THEN INFO(1) = -4 INFO(2) = K 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 = M IF (JOB.EQ.3) K = 1 IF (JOB.EQ.4) K = 2*M IF (JOB.EQ.5) K = N + 2*M IF (JOB.EQ.6) K = N + 3*M IF (LDW.LT.K) THEN INFO(1) = -5 INFO(2) = K 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 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(J),J=1,min(10,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,min(10,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(J),J=1,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,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) = IP(J+1) - IP(J) 10 CONTINUE CALL CMUMPS_457(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_444(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(2*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_451(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL CMUMPS_452(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) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1 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 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IW(1) = JOB CALL CMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) 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 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 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 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 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_451(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 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 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IW(1) = JOB IF (JOB.EQ.5) THEN CALL CMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL CMUMPS_454(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) 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 (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_443. INFO(1) = ',I2, & ' because ',(A),' = ',I10) 9004 FORMAT (' ****** Error in CMUMPS_443. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I8) 9005 FORMAT (' ****** Error in CMUMPS_443. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I8) 9006 FORMAT (' ****** Error in CMUMPS_443. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in CMUMPS_443. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from CMUMPS_443. 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_443:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I10) 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_443:'/ & ' 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_559 SUBROUTINE CMUMPS_563(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER N,NZ INTEGER IP(N+1),IRN(NZ) REAL A(NZ) INTEGER WR_POS,BEG_COL,ROW,COL,K,SV_POS INTEGER FLAG(N), POSI(N) FLAG = 0 WR_POS = 1 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1 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 RETURN END SUBROUTINE CMUMPS_563 SUBROUTINE CMUMPS_562(N,NZ,IP,IRN,FLAG,POSI) IMPLICIT NONE INTEGER N,NZ INTEGER IP(N+1),IRN(NZ) INTEGER WR_POS,BEG_COL,ROW,COL,K INTEGER FLAG(N), POSI(N) FLAG = 0 WR_POS = 1 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1 RETURN END SUBROUTINE CMUMPS_562 SUBROUTINE CMUMPS_181( 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_181 SUBROUTINE CMUMPS_746( ID, PTRAR ) USE CMUMPS_STRUC_DEF IMPLICIT NONE include 'mpif.h' TYPE(CMUMPS_STRUC), INTENT(IN), TARGET :: ID INTEGER, TARGET :: PTRAR(ID%N,2) INTEGER :: IERR INTEGER :: IOLD, K, JOLD, INEW, JNEW, INZ INTEGER, POINTER :: IIRN(:), IJCN(:), IWORK1(:), IWORK2(:) LOGICAL :: IDO, PARANAL PARANAL = .TRUE. IF (PARANAL) THEN IF(ID%KEEP(54) .EQ. 3) THEN IIRN => ID%IRN_loc IJCN => ID%JCN_loc INZ = ID%NZ_loc IWORK1 => PTRAR(1:ID%N,2) allocate(IWORK2(ID%N)) IDO = .TRUE. ELSE IIRN => ID%IRN IJCN => ID%JCN INZ = ID%NZ IWORK1 => PTRAR(1:ID%N,1) IWORK2 => PTRAR(1:ID%N,2) IDO = ID%MYID .EQ. 0 END IF ELSE IIRN => ID%IRN IJCN => ID%JCN INZ = ID%NZ 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 IWORK2(IOLD) = 0 50 CONTINUE IF(IDO) THEN DO 70 K=1,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 ELSE IWORK1(JOLD) = IWORK1(JOLD) + 1 ENDIF ELSE IF ( INEW .LT. JNEW ) THEN IWORK1( IOLD ) = IWORK1( IOLD ) + 1 ELSE IWORK1( JOLD ) = IWORK1( JOLD ) + 1 END IF ENDIF ENDIF 70 CONTINUE END IF IF(PARANAL .AND. (ID%KEEP(54) .EQ. 3) ) THEN CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1,1), ID%N, MPI_INTEGER, & MPI_SUM, ID%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), ID%N, MPI_INTEGER, & MPI_SUM, ID%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR, 2*ID%N, MPI_INTEGER, & 0, ID%COMM, IERR ) END IF RETURN END SUBROUTINE CMUMPS_746 MODULE CMUMPS_PARALLEL_ANALYSIS USE CMUMPS_STRUC_DEF USE TOOLS_COMMON INCLUDE 'mpif.h' PUBLIC CMUMPS_715 INTERFACE CMUMPS_715 MODULE PROCEDURE CMUMPS_715 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 :: NZ_LOC, 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 :: MEMCNT, MAXMEM, MP, MPG, LP, NRL, TOPROWS LOGICAL :: PROK, PROKG CONTAINS SUBROUTINE CMUMPS_715(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) 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%NZ_loc = id%NZ ELSE id%NZ_loc = 0 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) MEMCNT = size(work1)+ size(work2) + & size(nfsiz) + size(fils) + size(frere) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT entry:',MEMCNT,MAXMEM #endif CALL CMUMPS_716(id, ord) id%INFOG(7) = id%KEEP(245) CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL CMUMPS_717(id, ord, WORK2) CALL MUMPS_276( 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_733(IPE, id%N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NV, id%N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT ipe nv:',MEMCNT,MAXMEM #endif END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 CALL CMUMPS_720(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_276( 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_734(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT firstlast:',MEMCNT,MAXMEM #endif 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_733(CUMUL, id%N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT cumul:',MEMCNT,MAXMEM #endif NEMIN = id%KEEP(1) CALL CMUMPS_557(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_734(CUMUL, NV, IPE, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall cumul:',MEMCNT,MAXMEM #endif CALL CMUMPS_201(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_209(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_510(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 IF ( huge(id%KEEP8(79)) / K79REF + 1_8 .GE. & int(id%NSLAVES,8) ) THEN id%KEEP8(79)=huge(id%KEEP8(79)) ELSE id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF 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_97(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_97(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 #if defined (memprof) write(mp,'(i2,a30,3(i8,5x))')myid,'MEMCNT exit:',MEMCNT,MAXMEM, & estimem(myid, id%n, 2*id%nz/id%n) #endif RETURN END SUBROUTINE CMUMPS_715 SUBROUTINE CMUMPS_716(id, ord) TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: IERR #if defined(parmetis) 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) IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to PT-SCOTCH.")') RETURN #endif #if defined(parmetis) I=1 DO IF (I .GT. id%NSLAVES) 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.")') 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) I=1 DO IF (I .GT. id%NSLAVES) 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_716 SUBROUTINE CMUMPS_717(id, ord, WORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) #ifdef parmetis INTEGER :: IERR #endif IF (ord%ORDTOOL .EQ. 1) THEN #ifdef ptscotch CALL CMUMPS_719(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 #ifdef parmetis CALL CMUMPS_718(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_717 #if defined(parmetis) SUBROUTINE CMUMPS_718(id, ord, WORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR, BASE INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & EDGELOCNBR, OPTIONS(10), NROWS_LOC INTEGER, POINTER :: VERTLOCTAB(:), & EDGELOCTAB(:), RCVCNTS(:) 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) IF(MUMPS_795(WORK) .LT. ID%N*3) THEN WRITE(LP, & '("Insufficient workspace inside CMUMPS_718")') CALL MUMPS_ABORT() END IF CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, LP, & STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, LP, & STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT perm peri:', & MEMCNT,MAXMEM #endif BASEVAL = 1 BASE = id%NPROCS-id%NSLAVES VERTLOCTAB => ord%PERMTAB CALL MUMPS_733(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, & MAXMEM #endif DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO DO I=BASE, BASE+ord%NSLAVES-2 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) END DO FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* & (BASE+ord%NSLAVES-1-BASE)+1 LAST(BASE+ord%NSLAVES) = id%N DO I=BASE+ord%NSLAVES, NPROCS FIRST(I+1) = id%N+1 LAST(I+1) = id%N END DO VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 SWORK => WORK(id%N+1:3*id%N) CALL CMUMPS_776(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 OPTIONS(:) = 0 NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 ORDER => WORK(1:id%N) CALL MUMPS_733(SIZES, 2*ord%NSLAVES, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT sizes:',MEMCNT,MAXMEM #endif IF(ord%IDO) THEN CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB, & EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES) END IF CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM #endif NULLIFY(VERTLOCTAB) CALL MPI_BCAST(SIZES, 2*ord%NSLAVES, MPI_INTEGER, & BASE, id%COMM, IERR) ord%CBLKNBR = 2*ord%NSLAVES-1 CALL MUMPS_733(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rcvcnts:',MEMCNT,MAXMEM #endif 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, NROWS_LOC, MPI_INTEGER, ord%PERMTAB, & RCVCNTS, FIRST, MPI_INTEGER, id%COMM, IERR ) DO I=1, id%N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_733(ord%RANGTAB, 2*ord%NSLAVES, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rangtab:',MEMCNT,MAXMEM #endif CALL MUMPS_733(ord%TREETAB, ord%CBLKNBR, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_778(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_734(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sizes:',MEMCNT,MAXMEM #endif CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM #endif CALL CMUMPS_777(ord) ord%N = id%N ord%COMM = id%COMM RETURN END SUBROUTINE CMUMPS_718 #endif #if defined(ptscotch) SUBROUTINE CMUMPS_719(id, ord, WORK) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & EDGELOCNBR, MYWORKID, & BASE INTEGER, POINTER :: VERTLOCTAB(:), & EDGELOCTAB(:) DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) IF(MUMPS_795(WORK) .LT. ID%N*3) THEN WRITE(LP, & '("Insufficient workspace inside CMUMPS_719")') CALL MUMPS_ABORT() END IF IF(ord%SUBSTRAT .EQ. 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=n{sep=/(vert>120)?'// & '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=f{cmin=15,cmax=100000,frat=0.0},ose=g}}' ELSE 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 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_733(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, & MAXMEM #endif DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO DO I=BASE, BASE+ord%NSLAVES-2 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) END DO FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* & (BASE+ord%NSLAVES-1-BASE)+1 LAST(BASE+ord%NSLAVES) = id%N DO I=BASE+ord%NSLAVES, NPROCS-1 FIRST(I+1) = id%N+1 LAST(I+1) = id%N END DO VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 VERTLOCTAB => WORK(1:id%N) SWORK => WORK(id%N+1:3*id%N) CALL CMUMPS_776(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%RANGTAB, id%N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%TREETAB, id%N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT permtab:',MEMCNT,MAXMEM #endif IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF IF(ord%IDO) THEN CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in dgraph init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), VERTLOCTAB(1), & VERTLOCTAB(1), EDGELOCNBR, EDGELOCNBR, EDGELOCTAB(1), & EDGELOCTAB(1), EDGELOCTAB(1), IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in dgraph build")') CALL MUMPS_ABORT() END IF CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in strat init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in strat build")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order compute")') CALL MUMPS_ABORT() END IF IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB, ord%PERITAB, ord%CBLKNBR, ord%RANGTAB, & ord%TREETAB, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in Corder init")') CALL MUMPS_ABORT() END IF END IF IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order gather")') CALL MUMPS_ABORT() END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order gather")') CALL MUMPS_ABORT() END IF END IF END IF IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERITAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB, id%N+1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%TREETAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_777(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM #endif ord%N = id%N ord%COMM = id%COMM CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM #endif RETURN END SUBROUTINE CMUMPS_719 #endif FUNCTION CMUMPS_793(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: CMUMPS_793 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 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF CMUMPS_793 = .FALSE. IF(NACTIVE .GE. RPROC) THEN CMUMPS_793 = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN CMUMPS_793 = .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 NZ_ROW = 2*(id%NZ/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_793 = .TRUE. RETURN ELSE CMUMPS_793 = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION CMUMPS_793 FUNCTION CMUMPS_779(NODE, ord) IMPLICIT NONE INTEGER :: CMUMPS_779 INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR CMUMPS_779 = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE CMUMPS_779 = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN CMUMPS_779 = CMUMPS_779+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION CMUMPS_779 SUBROUTINE CMUMPS_781(ord, id) USE TOOLS_COMMON 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 ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1)) ALIST(1) = ord%CBLKNBR AWEIGHTS(1) = ord%NW(ord%CBLKNBR) NACTIVE = 1 RPROC = NNODES ANODE = 0 PEAKMEM = 0 CALL MUMPS_733(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%FIRST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%LAST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')ord%myid,'MEMCNT topnodes:',MEMCNT, & MAXMEM #endif ord%TOPNODES = 0 IF((ord%CBLKNBR .EQ. 1) .OR. & ( RPROC .LT. CMUMPS_779(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 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = CMUMPS_779(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_793(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_783(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL CMUMPS_784(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_783(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL CMUMPS_784(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_781 SUBROUTINE CMUMPS_720(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, POINTER :: PE(:), IPE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & RCVCNT(:), LSTVAR(:) INTEGER, POINTER :: NROOTS(:), MYLIST(:), & MYNVAR(:), LVARPT(:), & DISPLS(:), LPERM(:), & LIPERM(:), & IPET(:), NVT(:), BUF_PE1(:), & BUF_PE2(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP1(:), TMP2(:), BWORK(:) INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, MYNROOTS, PNT, TMP, & NCLIQUES, NTVAR, PFREES, PFREET, TGSIZE, MAXS, RHANDPE, & RHANDNV, STATUSPE(MPI_STATUS_SIZE), & STATUSNV(MPI_STATUS_SIZE), RIDX, PROC, NBBUCK, & PFS_SAVE, PFT_SAVE LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, RCVCNT, LSTVAR) nullify(NROOTS, MYLIST, MYNVAR, LVARPT, DISPLS, & 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_795(WORK) .LT. 4*id%N) THEN WRITE(LP,*)'Insufficient workspace in CMUMPS_720' 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_781(ord, id) CALL MUMPS_734(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))') myid,'deall son:',MEMCNT,MAXMEM #endif 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_775(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK) 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_733(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT allsub:',MEMCNT,MAXMEM #endif 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 IF (ord%SUBSTRAT .EQ. 0) THEN DO I=1, HIDX PERM(I) = I END DO CALL MUMPS_420(1, THRESH, NDENSE(1), HIDX, & MUMPS_795(PE), 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) ELSE NBBUCK = 2*TMP CALL MUMPS_419 (ord%SUBSTRAT, 1, .FALSE., HIDX, NBBUCK, & MUMPS_795(PE), IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), PERM(1), NEXT(1), & W(1), HEAD(1), AGG6, SIZE_SCHUR, LISTVAR_SCHUR(1) ) DO I=1, HIDX PERM(I) = I END DO END IF CALL MUMPS_733(W, 2*NPROCS, id%INFO, & LP, STRING='W', MEMCNT=MEMCNT, ERRCODE=-7) if(MEMCNT .gt. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT w:',MEMCNT,MAXMEM #endif NROOTS => W DISPLS => W(NPROCS+1:2*NPROCS) MYNVAR => DEGREE MYLIST => NDENSE LVARPT => NEXT RCVCNT => HEAD LSTVAR => LAST NULLIFY(W, DEGREE, NDENSE, NEXT, HEAD, LAST) MYNROOTS = 0 PNT = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN PNT = PNT+LENG(I) MYNROOTS = MYNROOTS+1 END IF END DO CALL MUMPS_733(MYLIST, PNT, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT mylist:',MEMCNT,MAXMEM #endif MYNROOTS = 0 PNT = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYNROOTS = MYNROOTS+1 MYNVAR(MYNROOTS) = LENG(I) DO J=1, LENG(I) MYLIST(PNT+J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO PNT = PNT+LENG(I) END IF END DO CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_GATHER(MYNROOTS, 1, MPI_INTEGER, NROOTS(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) IF(MYID .EQ.0) THEN DISPLS(1) = 0 DO I=2, NPROCS DISPLS(I) = DISPLS(I-1)+NROOTS(I-1) END DO NCLIQUES = sum(NROOTS(1:NPROCS)) CALL MUMPS_733(LVARPT, NCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ELSE CALL MUMPS_733(LVARPT, 2, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT lvarpt:',MEMCNT,MAXMEM #endif CALL MPI_GATHERV(MYNVAR(1), MYNROOTS, MPI_INTEGER, LVARPT(2), & NROOTS(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) IF(MYID .EQ. 0) THEN DO I=1, NPROCS RCVCNT(I) = sum(LVARPT(2+DISPLS(I):2+DISPLS(I)+NROOTS(I)-1)) IF(I .EQ. 1) THEN DISPLS(I) = 0 ELSE DISPLS(I) = DISPLS(I-1)+RCVCNT(I-1) END IF END DO CALL MUMPS_733(LSTVAR, sum(RCVCNT(1:NPROCS)), id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT lstvar:',MEMCNT,MAXMEM #endif END IF CALL MPI_GATHERV(MYLIST(1), PNT, MPI_INTEGER, LSTVAR(1), & RCVCNT(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) NULLIFY(DISPLS) IF(MYID .EQ. 0) THEN LVARPT(1) = 1 DO I=2, NCLIQUES+1 LVARPT(I) = LVARPT(I-1) + LVARPT(I) END DO LPERM => WORK(3*id%N+1 : 4*id%N) NTVAR = ord%TOPNODES(2) CALL CMUMPS_782(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL CMUMPS_774(id, ord%TOPNODES(2), LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPET, PE, LENG, ELEN) TGSIZE = ord%TOPNODES(2)+NCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) CALL MUMPS_734(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) W => NROOTS DEGREE => MYNVAR NDENSE => MYLIST NEXT => LVARPT HEAD => RCVCNT LAST => LSTVAR NULLIFY(NROOTS, MYNVAR, MYLIST, LVARPT, RCVCNT, LSTVAR) CALL MUMPS_733(PE, max(PFREET+TGSIZE,1), id%INFO, LP, & COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LISTVAR_SCHUR, max(NCLIQUES,1), id%INFO, LP, & STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT pe:',MEMCNT,MAXMEM #endif DO I=1, NCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 IF(ord%TOPSTRAT .EQ. 0) THEN CALL MUMPS_733(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rehead:',MEMCNT,MAXMEM #endif DO I=1, TGSIZE PERM(I) = I END DO CALL MUMPS_420(2, -1, NDENSE(1), TGSIZE, & MUMPS_795(PE), 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), NCLIQUES, & AGG6) ELSE NBBUCK = 2*TGSIZE CALL MUMPS_733(HEAD, NBBUCK+2, id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(PERM, TGSIZE, id%INFO, & LP, STRING='J2:PERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rehead:',MEMCNT,MAXMEM #endif CALL MUMPS_419 (ord%TOPSTRAT, 2, .FALSE., TGSIZE, & NBBUCK, MUMPS_795(PE), IPET(1), PFREET, LENG(1), & PE(1), NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), & PERM(1), NEXT(1), W(1), HEAD(1), AGG6, NCLIQUES, & LISTVAR_SCHUR(1) ) END IF END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MUMPS_734(LISTVAR_SCHUR, PE, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall lvs:',MEMCNT,MAXMEM #endif IF(MYID .EQ. 0) THEN BUF_PE1 => WORK( 1 : id%N) BUF_PE2 => WORK( id%N+1 : 2*id%N) BUF_NV1 => WORK(2*id%N+1 : 3*id%N) BUF_NV2 => WORK(3*id%N+1 : 4*id%N) 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_733(BUF_PE1, MAXS, id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_PE2, MAXS, id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_NV1, MAXS, id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_NV2, MAXS, id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(GPE, id%N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(GNV, id%N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ROOTPERM, NCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT buf_pe1:',MEMCNT, & MAXMEM #endif 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_INTEGER, 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, NCLIQUES 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_INTEGER, 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_734(PE, IPE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_734(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_734(LSTVAR, NROOTS, MYLIST, MYNVAR, & LVARPT, MEMCNT=MEMCNT) CALL MUMPS_734(LPERM, LIPERM, IPET, NVT, & MEMCNT=MEMCNT) CALL MUMPS_734(ROOTPERM, TMP1, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, RCVCNT) RETURN END SUBROUTINE CMUMPS_720 SUBROUTINE CMUMPS_782(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_733(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT lperm:',MEMCNT, & MAXMEM #endif 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_782 SUBROUTINE CMUMPS_774(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(:), LVARPT(:), & IPE(:), PE(:), LENG(:), ELEN(:) INTEGER :: NCLIQUES INTEGER :: I, J, IDX, NLOCVARS, PNT, SAVEPNT CALL MUMPS_733(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT leng:',MEMCNT, & MAXMEM #endif LENG = 0 ELEN = 0 DO I=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN LENG(LPERM(top_graph%IRN_LOC(I))) = & LENG(LPERM(top_graph%IRN_LOC(I))) + 1 END IF END DO DO I=1, NCLIQUES DO J=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+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)+LENG(I)+ELEN(I) END DO CALL MUMPS_733(PE, IPE(NLOCVARS+NCLIQUES+1)+NLOCVARS+NCLIQUES, & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT repe:',MEMCNT, & MAXMEM #endif LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO J=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(J)) PE(IPE(IDX)+ELEN(IDX)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+LENG(NLOCVARS+I)) = IDX ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO I=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN PE(IPE(LPERM(top_graph%IRN_LOC(I)))+ & ELEN(LPERM(top_graph%IRN_LOC(I))) + & LENG(LPERM(top_graph%IRN_LOC(I)))) = & LPERM(top_graph%JCN_LOC(I)) LENG(LPERM(top_graph%IRN_LOC(I))) = & LENG(LPERM(top_graph%IRN_LOC(I))) + 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 J=IPE(I), IPE(I+1)-1 IF(LPERM(PE(J)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE CMUMPS_774 SUBROUTINE CMUMPS_778(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:2) = (/1, 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_778 SUBROUTINE CMUMPS_776(id, FIRST, LAST, IPE, & PE, WORK) IMPLICIT NONE INCLUDE 'mpif.h' TYPE(CMUMPS_STRUC) :: id INTEGER, POINTER :: FIRST(:), LAST(:), IPE(:), PE(:), & WORK(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, LOCNNZ, & NEW_LOCNNZ, J, LOC_ROW INTEGER :: TOP_CNT, TIDX, & NROWS_LOC, DUPS, TOTDUPS, OFFDIAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), & SNDCNT(:), RCVCNT(:), SDISPL(:) INTEGER, POINTER :: RDISPL(:), & MSGCNT(:), SIPES(:,:), LENG(:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, & SAVEPNT INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL) nullify(RDISPL, MSGCNT, SIPES, LENG) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_795(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_733(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT sndcnt:',MEMCNT,MAXMEM #endif ALLOCATE(APNT(NPROCS)) SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 1000 LOCNNZ = id%NZ_loc 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 I=1, id%NZ_loc IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(I)) LOC_ROW = id%IRN_loc(I)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(I)) LOC_ROW = id%JCN_loc(I)-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%KEEP(114), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) id%KEEP(114) = id%KEEP(114)+3*id%N id%KEEP(113) = id%KEEP(114)-2*id%N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, id%COMM, IERR) SNDCNT(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) CALL MUMPS_733(IPE, NROWS_LOC+1, id%INFO, & LP, STRING='IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT ripe:',MEMCNT,MAXMEM #endif IPE(1) = 1 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + LENG(I) END DO CALL MUMPS_733(PE, max(IPE(NROWS_LOC+1)-1,1), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe:',MEMCNT,MAXMEM #endif LENG(:) = 0 CALL CMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) NEW_LOCNNZ = sum(RCVCNT) DO I=1, NPROCS MSGCNT(I) = RCVCNT(I)/BUFSIZE END DO RCVPNT = 1 SNDCNT = 0 TIDX = 0 DO I=1, id%NZ_loc IF(mod(I,BUFSIZE/10) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, MPI_COMM_WORLD, STATUS, IERR) CALL CMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%IRN_loc(I)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%JCN_loc(I) SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF PROC = MAPTAB(id%JCN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%JCN_loc(I)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%IRN_loc(I) SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF END DO CALL CMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO J=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(J)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER, MPI_SUM, & 0, id%COMM, IERR ) SYMMETRY = dble(TOTDUPS)/(dble(id%NZ)-dble(id%N)) IF(MYID .EQ. 0) THEN IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'("Structual symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_734(SNDCNT, RCVCNT, MSGCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM #endif RETURN END SUBROUTINE CMUMPS_776 SUBROUTINE CMUMPS_775(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK) IMPLICIT NONE INCLUDE 'mpif.h' TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: IPE(:), PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, LOCNNZ, & NEW_LOCNNZ, J, LOC_ROW INTEGER :: TOP_CNT,IIDX,JJDX INTEGER :: HALO_SIZE, TIDX, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), & SNDCNT(:), RCVCNT(:), & SDISPL(:), HALO_MAP(:) INTEGER, POINTER :: RDISPL(:), & MSGCNT(:), SIPES(:,:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, & SAVEPNT INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_795(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_733(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rrsndcnt:',MEMCNT,MAXMEM #endif ALLOCATE(APNT(NPROCS)) SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 LOCNNZ = id%NZ_loc 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 I=1, id%NZ_loc IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(I)) 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(I)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(I)) 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_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, id%COMM, IERR) I = ceiling(real(MAXS)*1.20E0) CALL MUMPS_733(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrleng2:',MEMCNT, & MAXMEM #endif SNDCNT(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(real(NROWS_LOC+1)*1.20E0) CALL MUMPS_733(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rripe:',MEMCNT,MAXMEM #endif IPE(1) = 1 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + LENG(I) END DO CALL MUMPS_733(TSENDI, max(TOP_CNT,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(TSENDJ, max(TOP_CNT,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT tsendi:',MEMCNT,MAXMEM #endif LENG(:) = 0 CALL CMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) NEW_LOCNNZ = sum(RCVCNT) DO I=1, NPROCS MSGCNT(I) = RCVCNT(I)/BUFSIZE END DO CALL MUMPS_733(PE, max(NEW_LOCNNZ+2*NROWS_LOC,1), id%INFO, & LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe2:',MEMCNT,MAXMEM #endif RCVPNT = 1 SNDCNT = 0 TIDX = 0 DO I=1, id%NZ_loc IF(mod(I,BUFSIZE/10) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, MPI_COMM_WORLD, STATUS, IERR) CALL CMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(I) TSENDJ(TIDX) = id%JCN_loc(I) ELSE IIDX = ord%PERMTAB(id%IRN_loc(I)) JJDX = ord%PERMTAB(id%JCN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) =IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%JCN_loc(I) END IF SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(I)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(I) TSENDJ(TIDX) = id%IRN_loc(I) ELSE IIDX = ord%PERMTAB(id%JCN_loc(I)) JJDX = ord%PERMTAB(id%IRN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%IRN_loc(I) END IF SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF END IF END DO CALL CMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO J=IPE(I),IPE(I+1)-1 IF(PE(J) .LT. 0) THEN IF(HALO_MAP(-PE(J)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(J)) = NROWS_LOC+HALO_SIZE END IF PE(J) = HALO_MAP(-PE(J)) END IF IF(MAPTAB(PE(J)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_733(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT i_halo:',MEMCNT,MAXMEM #endif 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_733(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_733(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT lengipe:',MEMCNT, & MAXMEM #endif 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_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) RDISPL => MSGCNT NULLIFY(MSGCNT) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) RDISPL(1) = 0 DO I=2, NPROCS RDISPL(I) = RDISPL(I-1)+RCVCNT(I-1) END DO top_graph%NZ_LOC = NEW_LOCNNZ top_graph%COMM = id%COMM CALL MUMPS_733(top_graph%IRN_LOC, NEW_LOCNNZ, id%INFO, & LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(top_graph%JCN_LOC, NEW_LOCNNZ, id%INFO, & LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT top_graph:',MEMCNT, & MAXMEM #endif ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1)) END IF CALL MPI_GATHERV(TSENDI(1), TOP_CNT, MPI_INTEGER, & top_graph%IRN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, & 0, id%COMM, IERR) CALL MPI_GATHERV(TSENDJ(1), TOP_CNT, MPI_INTEGER, & top_graph%JCN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, & 0, id%COMM, IERR) CALL MUMPS_734(SNDCNT, RCVCNT, RDISPL, & TSENDI, TSENDJ, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM #endif DEALLOCATE(APNT) RETURN END SUBROUTINE CMUMPS_775 SUBROUTINE CMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER :: NPROCS, PROC, COMM TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:), IPE(:) INTEGER :: MSGCNT(:), SNDCNT(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE, TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE), & 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_773(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_773(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_773(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_785 SUBROUTINE CMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) #ifdef MPELOG USE MPEMOD INCLUDE 'mpif.h' #endif IMPLICIT NONE INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), IPE(:), PE(:), LENG(:) INTEGER :: I, ROW, COL #ifdef MPELOG INTEGER ::IERR IERR = MPE_LOG_EVENT( MPE_ASM_BUF1, 0, '' ) #endif 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 #ifdef MPELOG IERR = MPE_LOG_EVENT( MPE_ASM_BUF2, 0, '' ) #endif RETURN END SUBROUTINE CMUMPS_773 SUBROUTINE CMUMPS_777(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_777 SUBROUTINE CMUMPS_784(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_784 SUBROUTINE CMUMPS_783(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_783 FUNCTION MUMPS_795(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_795 IF(associated(A)) THEN MUMPS_795 = size(A) ELSE MUMPS_795 = 0 END IF RETURN END FUNCTION MUMPS_795 SUBROUTINE MUMPS_734(A1, A2, A3, A4, A5, A6, A7, MEMCNT) INTEGER, POINTER :: A1(:) INTEGER, POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:), & A6(:), A7(:) INTEGER, OPTIONAL :: MEMCNT INTEGER :: IMEMCNT IMEMCNT = 0 IF(associated(A1)) THEN IMEMCNT = IMEMCNT+size(A1) DEALLOCATE(A1) END IF IF(present(A2)) THEN IF(associated(A2)) THEN IMEMCNT = IMEMCNT+size(A2) DEALLOCATE(A2) END IF END IF IF(present(A3)) THEN IF(associated(A3)) THEN IMEMCNT = IMEMCNT+size(A3) DEALLOCATE(A3) END IF END IF IF(present(A4)) THEN IF(associated(A4)) THEN IMEMCNT = IMEMCNT+size(A4) DEALLOCATE(A4) END IF END IF IF(present(A5)) THEN IF(associated(A5)) THEN IMEMCNT = IMEMCNT+size(A5) DEALLOCATE(A5) END IF END IF IF(present(A6)) THEN IF(associated(A6)) THEN IMEMCNT = IMEMCNT+size(A6) DEALLOCATE(A6) END IF END IF IF(present(A7)) THEN IF(associated(A7)) THEN IMEMCNT = IMEMCNT+size(A7) DEALLOCATE(A7) END IF END IF IF(present(MEMCNT)) MEMCNT = MEMCNT-IMEMCNT RETURN END SUBROUTINE MUMPS_734 #if defined(memprof) FUNCTION ESTIMEM(MYID, N, NZR) INTEGER :: ESTIMEM, MYID, NZR, N IF(MYID.EQ.0) THEN ESTIMEM = 12*N ELSE ESTIMEM = 7*N END IF IF(MYID.NE.0) TOPROWS=0 IF(MYID .EQ. 0) ESTIMEM = ESTIMEM+2*TOPROWS*NZR ESTIMEM = ESTIMEM+NRL ESTIMEM = ESTIMEM+max(NRL,TOPROWS)*(NZR+2) ESTIMEM = ESTIMEM+6*max(NRL,TOPROWS) IF(MYID.EQ.0) ESTIMEM=ESTIMEM+3*TOPROWS RETURN END FUNCTION ESTIMEM #endif END MODULE SUBROUTINE CMUMPS_448(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_448 SUBROUTINE CMUMPS_444 & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER M,N,NE,NUM INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),PR(N),Q(M),L(M) REAL A(NE) REAL D(M), RINF INTEGER I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & K,KK,KK1,KK2,I0,UP,LOW 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_445, CMUMPS_446, CMUMPS_447, CMUMPS_455 RLX = D(1) NUM = 0 BV = RINF DO 10 K = 1,N JPERM(K) = 0 PR(K) = IP(K) 10 CONTINUE DO 12 K = 1,M IPERM(K) = 0 D(K) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1 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 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 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 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1 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 DO 115 K = IP(J),IP(J+1)-1 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_445(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = J 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_446(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 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_447(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_445(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = J 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 = PR(J) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 KK = UP,M I = Q(KK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 KK = LOW,UP-1 I = Q(KK) D(I) = MINONE 192 CONTINUE DO 193 KK = 1,QLEN I = Q(KK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL CMUMPS_455(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE CMUMPS_444 SUBROUTINE CMUMPS_445(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_445 SUBROUTINE CMUMPS_446(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_446 SUBROUTINE CMUMPS_447(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_447 SUBROUTINE CMUMPS_450(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER WLEN,NVAL INTEGER IP(*),LENL(*),LENH(*),W(*) REAL A(*),VAL INTEGER XX,J,K,II,S,POS PARAMETER (XX=10) REAL SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+LENL(J),IP(J)+LENH(J)-1 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_450 SUBROUTINE CMUMPS_451(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER N,NE INTEGER IP(N+1),IRN(NE) REAL A(NE) INTEGER THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER J,IPJ,K,LEN,R,S,HI,FIRST,MID,LAST,TD REAL HA,KEY INTEGER TODO(TDLEN) DO 100 J = 1,N LEN = 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 + LEN TD = 2 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 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 425 CONTINUE IF (TD.EQ.0) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.THRESH) GO TO 500 TD = TD - 2 GO TO 425 400 DO 200 R = IPJ+1,IPJ+LEN-1 IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1) IRN(R) = IRN(R-1) DO 300 S = R-1,IPJ+1,-1 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_451 SUBROUTINE CMUMPS_452(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER M,N,NE,NUMX INTEGER IP(N+1),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,II,I,J,K,L,CNT,MOD,IDUM1,IDUM2,IDUM3 REAL BVAL,BMIN,BMAX EXTERNAL CMUMPS_450,CMUMPS_453,CMUMPS_455 DO 20 J = 1,N FC(J) = J LEN(J) = 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_453(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 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 = IP(J+1) - IP(J) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = K - IP(J) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 IDUM1 = 1,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 IDUM2 = 1,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL CMUMPS_450(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM3 = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+LEN(J)-1,IP(J)+LENL(J),-1 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) = 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_450(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM3 = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+LEN(J),IP(J)+LENH(J)-1 IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = 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_453(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_455(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE CMUMPS_452 SUBROUTINE CMUMPS_453 & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER ID,MOD,M,N,LIRN,NUM,NUMX INTEGER ARP(N),CV(M),IRN(LIRN),IP(N), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK,LAST,NFC, & NUM0,NUM1,NUM2,ID0,ID1 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) + ARP(J) IN2 = IP(J) + LENC(J) - 1 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 = OUT(J) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + LENC(J) - 1 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) = 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) = 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) + LENC(J) - OUT(J) - 2 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_453 SUBROUTINE CMUMPS_454(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER M,N,NE,NUM INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),OUT(N),PR(N),Q(M),L(M) REAL A(NE),U(M),D(M),RINF,RINF3 INTEGER I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,ISP,JSP, & K,K0,K1,K2,KK,KK1,KK2,UP,LOW REAL CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL LORD REAL ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) EXTERNAL CMUMPS_445, CMUMPS_446, CMUMPS_447, CMUMPS_455 RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 K = 1,N JPERM(K) = 0 PR(K) = IP(K) D(K) = RINF 10 CONTINUE DO 15 K = 1,M U(K) = RINF3 IPERM(K) = 0 L(K) = 0 15 CONTINUE DO 30 J = 1,N IF (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) 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 K = 1,M D(K) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1 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 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 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF L(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 DO 115 K = IP(J),IP(J+1)-1 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 Q(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 KK = 1,Q0 K = Q(KK) 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 Q(LOW) = I L(I) = LOW ELSE QLEN = QLEN + 1 L(I) = QLEN CALL CMUMPS_445(I,M,Q,D,L,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = J 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL CMUMPS_446(QLEN,M,Q,D,L,2) LOW = LOW - 1 Q(LOW) = I L(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = Q(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 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 (L(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 (L(I).NE.0) THEN CALL CMUMPS_447(L(I),QLEN,M,Q,D,L,2) ENDIF LOW = LOW - 1 Q(LOW) = I L(I) = LOW ELSE IF (L(I).EQ.0) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL CMUMPS_445(I,M,Q,D,L,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = J 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 = 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 KK = UP,M I = Q(KK) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 KK = UP,M I = Q(KK) D(I) = RINF L(I) = 0 191 CONTINUE DO 192 KK = LOW,UP-1 I = Q(KK) D(I) = RINF L(I) = 0 192 CONTINUE DO 193 KK = 1,QLEN I = Q(KK) D(I) = RINF L(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_455(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE CMUMPS_454 SUBROUTINE CMUMPS_457 & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER LIRN,M,N,NUM INTEGER ARP(N),CV(M),IRN(LIRN),IP(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK EXTERNAL CMUMPS_455 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 = ARP(J) IF (IN1.LT.0) GO TO 30 IN2 = IP(J) + LENC(J) - 1 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 = OUT(J) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + LENC(J) - 1 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) = IN2 - II - 1 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) = IN2 - II - 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 1000 II = IP(J) + LENC(J) - OUT(J) - 2 I = IRN(II) IPERM(I) = J 90 CONTINUE 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL CMUMPS_455(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE CMUMPS_457 SUBROUTINE CMUMPS_455(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_455 mumps-4.10.0.dfsg/src/mumps_size.c0000644000175300017530000000452311562233011017225 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ /* 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-4.10.0.dfsg/src/Makefile0000644000175300017530000000462711562233000016331 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # 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 = \ mumps_part9.o\ mumps_common.o\ mumps_ooc_common.o\ mumps_orderings.o\ mumps_size.o\ mumps_io.o\ mumps_io_basic.o\ mumps_io_thread.o\ mumps_io_err.o\ mumps_static_mapping.o\ mumps_sol_es.o\ tools_common_mod.o OBJS = $(ARITH)mumps_part1.o\ $(ARITH)mumps_part2.o\ $(ARITH)mumps_part3.o\ $(ARITH)mumps_part4.o\ $(ARITH)mumps_part5.o\ $(ARITH)mumps_part6.o\ $(ARITH)mumps_part7.o\ $(ARITH)mumps_part8.o\ $(ARITH)mumps_comm_buffer.o\ $(ARITH)mumps_load.o\ $(ARITH)mumps_c.o\ $(ARITH)mumps_ooc_buffer.o\ $(ARITH)mumps_ooc.o\ $(ARITH)mumps_struc_def.o $(libdir)/libmumps_common$(PLAT)$(LIBEXT): $(OBJS_COMMON) $(AR)$@ $? $(RANLIB) $@ $(libdir)/lib$(ARITH)mumps$(PLAT)$(LIBEXT): $(OBJS) $(AR)$@ $? $(RANLIB) $@ $(ARITH)mumps_load.o: $(ARITH)mumps_comm_buffer.o \ $(ARITH)mumps_struc_def.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)mumps_part1.o \ $(ARITH)mumps_part2.o \ $(ARITH)mumps_part3.o \ $(ARITH)mumps_part4.o \ $(ARITH)mumps_part5.o \ $(ARITH)mumps_part6.o \ $(ARITH)mumps_part7.o \ $(ARITH)mumps_part8.o: $(ARITH)mumps_comm_buffer.o \ $(ARITH)mumps_load.o \ $(ARITH)mumps_ooc.o $(ARITH)mumps_part5.o: mumps_static_mapping.o $(ARITH)mumps_part5.o: $(ARITH)mumps_part2.o $(ARITH)mumps_part2.o : tools_common_mod.o $(ARITH)mumps_part8.o : mumps_sol_es.o .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 $? $(OUTC)$@ clean: $(RM) *.o *.mod mumps-4.10.0.dfsg/src/smumps_ooc.F0000644000175300017530000035515311562233065017202 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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 #if defined (NEW_PREF_SCHEME) INTEGER,SAVE :: MAX_PREF_SIZE #endif & ,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_575,SMUMPS_576, & SMUMPS_577, & SMUMPS_578, & SMUMPS_579, & SMUMPS_582, & SMUMPS_583,SMUMPS_584, & SMUMPS_585,SMUMPS_586 INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC SMUMPS_688, & SMUMPS_690 PRIVATE SMUMPS_695, & SMUMPS_697 CONTAINS SUBROUTINE SMUMPS_711( 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_711 FUNCTION SMUMPS_579(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL SMUMPS_579 SMUMPS_579=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION SMUMPS_579 SUBROUTINE SMUMPS_590(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE SMUMPS_590 SUBROUTINE SMUMPS_575(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*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 CALL SMUMPS_588(id,IERR) 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_796(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_711( 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_669(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_589(TMP_DIR(1), & id%OOC_TMPDIR, TMPDIR_MAX_LENGTH, DIM_DIR ) CALL SMUMPS_589(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,kind=4)+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_575 SUBROUTINE SMUMPS_576(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_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_678 & (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_707(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_707(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_689(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_576 SUBROUTINE SMUMPS_577(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE REAL DEST INTEGER ASYNC LOGICAL IO_C #if defined(OLD_READ) INTEGER REQUEST #endif 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. #if ! defined(OLD_READ) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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 #else OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) 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 ) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_READ_OOC' ENDIF RETURN 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 #endif 555 CONTINUE IF(.NOT.SMUMPS_727())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_728() ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_577 SUBROUTINE SMUMPS_591(IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL SMUMPS_675(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE SMUMPS_591 SUBROUTINE SMUMPS_592(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_659() 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_613(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_592 SUBROUTINE SMUMPS_588(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*1 TMP_NAME(350) IERR=0 K=1 IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,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 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_588 SUBROUTINE SMUMPS_587(id,IERR) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC), TARGET :: id INTEGER IERR IERR=0 CALL SMUMPS_588(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_587 SUBROUTINE SMUMPS_586(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_275 INTEGER MUMPS_275 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_VADDR) ENDIF CALL MUMPS_796(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_614(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_586' 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_711( 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_586' id%INFO(1) = -11 CALL MUMPS_731(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_586' 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_586' 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_586' 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_586' 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_275( & 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_275( & 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 #if defined (NEW_PREF_SCHEME) MAX_PREF_SIZE=(1024*1024*2)/8 #endif RETURN END SUBROUTINE SMUMPS_586 SUBROUTINE SMUMPS_585(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_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL SMUMPS_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_585 SUBROUTINE SMUMPS_594(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA REAL A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL SMUMPS_603(ZONE) IERR=0 CALL SMUMPS_611(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE SMUMPS_594 SUBROUTINE SMUMPS_595(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_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_597(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL SMUMPS_597(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_596(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE SMUMPS_595 SUBROUTINE SMUMPS_596(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_330,MUMPS_275 INTEGER MUMPS_330,MUMPS_275 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_330(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_275( & 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_330(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_275( & 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_596 SUBROUTINE SMUMPS_597(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_596(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_597',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_597',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_597 ',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_597 SUBROUTINE SMUMPS_598(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_598', & 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_600(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_608(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_601(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_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL SMUMPS_603(ZONE) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_598 FUNCTION SMUMPS_726(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_726 IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN SMUMPS_726=OOC_NODE_PERMUTED ELSE SMUMPS_726=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.SMUMPS_727())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_728() 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_596(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL SMUMPS_599(INODE,PTRFAC,NSTEPS) IF(.NOT.SMUMPS_727())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_728() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN SMUMPS_726=OOC_NODE_PERMUTED ELSE SMUMPS_726=OOC_NODE_NOT_PERMUTED ENDIF ELSE SMUMPS_726=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION SMUMPS_726 SUBROUTINE SMUMPS_682(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_682 SUBROUTINE SMUMPS_599(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_610(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_609(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE SMUMPS_599 SUBROUTINE SMUMPS_600(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_600 SUBROUTINE SMUMPS_601(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE SMUMPS_601 SUBROUTINE SMUMPS_603(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_603 SUBROUTINE SMUMPS_578(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_608(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_606(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(SMUMPS_579(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL SMUMPS_604(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_606(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL SMUMPS_605(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL SMUMPS_605(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL SMUMPS_604(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_606(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL SMUMPS_608(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_606(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_578 SUBROUTINE SMUMPS_604(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_604', & 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_596( & 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_604' 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_604' 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_604 SUBROUTINE SMUMPS_605(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_605', & 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_596( & 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_605' 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_605' 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_596( & 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_605' 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_605 SUBROUTINE SMUMPS_606(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_606 SUBROUTINE SMUMPS_607(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_607' 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_607 SUBROUTINE SMUMPS_608(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_608',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_596( & 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_596( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' SMUMPS_608',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_596( & 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_608 SUBROUTINE SMUMPS_609(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_609' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_610(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_609 SUBROUTINE SMUMPS_610(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_610 FUNCTION SMUMPS_727() IMPLICIT NONE LOGICAL SMUMPS_727 SMUMPS_727=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN SMUMPS_727=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN SMUMPS_727=.TRUE. ENDIF ENDIF RETURN END FUNCTION SMUMPS_727 SUBROUTINE SMUMPS_611(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_727())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_727())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL SMUMPS_728() 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_727())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL SMUMPS_728() 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_604(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_605(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_605(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_604(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_608(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL SMUMPS_602(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_595(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE SMUMPS_611 SUBROUTINE SMUMPS_602(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_727())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_602',FLAG CALL MUMPS_ABORT() ENDIF CALL SMUMPS_728() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 #if defined (NEW_PREF_SCHEME) IF(MAX_SIZE.GT.MAX_PREF_SIZE)THEN MAX_SIZE=MIN(MAX(MAX_PREF_SIZE, & SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE)), & MAX_SIZE) ENDIF #endif 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_602 SUBROUTINE SMUMPS_582(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_582 SUBROUTINE SMUMPS_612(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_600(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).OR.(J.NE.SPECIAL_ROOT_NODE) & .OR.(ZONE.NE.NB_Z))THEN CALL SMUMPS_599(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.ALREADY_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_599(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_608(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_608 =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_612 SUBROUTINE SMUMPS_583(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_808 EXTERNAL MUMPS_808 IERR = 0 OOC_FCT_TYPE=MUMPS_808("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_612(PTRFAC,NSTEPS,A,LA) ELSE CALL SMUMPS_683(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL SMUMPS_585(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE SMUMPS_583 SUBROUTINE SMUMPS_584(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_808 EXTERNAL MUMPS_808 IERR=0 OOC_FCT_TYPE=MUMPS_808("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_612(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT) THEN CALL SMUMPS_598 ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN CALL SMUMPS_600(IROOT, & ZONE,PTRFAC,NSTEPS) IF(IROOT.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL SMUMPS_608(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & SMUMPS_608', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL SMUMPS_594(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL SMUMPS_683(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL SMUMPS_585(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE SMUMPS_584 SUBROUTINE SMUMPS_613(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*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_613' 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_613' 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_613 SUBROUTINE SMUMPS_614(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC), TARGET :: id CHARACTER*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_614' 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_614 SUBROUTINE SMUMPS_589(DEST,SRC,NB,NB_EFF) IMPLICIT NONE INTEGER NB, NB_EFF CHARACTER(LEN=NB) SRC CHARACTER*1 DEST(NB) INTEGER I DO I=1,NB_EFF DEST(I)=SRC(I:I) ENDDO END SUBROUTINE SMUMPS_589 SUBROUTINE SMUMPS_580(IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL SMUMPS_707(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE SMUMPS_580 SUBROUTINE SMUMPS_681(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_707(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE SMUMPS_681 SUBROUTINE SMUMPS_683(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_683 SUBROUTINE SMUMPS_688 & ( 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_695( 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_695( 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_688 SUBROUTINE SMUMPS_695( 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_690(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = SMUMPS_725 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = SMUMPS_725 & (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_695 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_695,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_695', & 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_695 ', & ' 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_697( 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_695 ', & ' 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_695" 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_695 SUBROUTINE SMUMPS_697( & 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_653( 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_697 INTEGER(8) FUNCTION SMUMPS_725 & (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_725 = TOTSIZE RETURN END FUNCTION SMUMPS_725 INTEGER FUNCTION SMUMPS_690( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER SMUMPS_748 SMUMPS_690=SMUMPS_748( & HBUF_SIZE, NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION SMUMPS_690 SUBROUTINE SMUMPS_728() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.SMUMPS_727())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_728 SUBROUTINE SMUMPS_809(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_809 END MODULE SMUMPS_OOC mumps-4.10.0.dfsg/src/dmumps_comm_buffer.F0000644000175300017530000031104611562233066020661 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE DMUMPS_COMM_BUFFER PRIVATE PUBLIC :: DMUMPS_61, DMUMPS_528, & DMUMPS_53 , DMUMPS_57 , & DMUMPS_55, DMUMPS_59, & DMUMPS_54,DMUMPS_58, & DMUMPS_66, DMUMPS_78, & DMUMPS_62, DMUMPS_68, & DMUMPS_71, DMUMPS_70, & DMUMPS_67, & DMUMPS_65, DMUMPS_64, & DMUMPS_72, & DMUMPS_648, DMUMPS_76, & DMUMPS_73, DMUMPS_74, & DMUMPS_63,DMUMPS_77, & DMUMPS_60, & DMUMPS_524, DMUMPS_469, & DMUMPS_460, DMUMPS_502, & DMUMPS_519 ,DMUMPS_620 & ,DMUMPS_617 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 BUF_LMAX_ARRAY DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY CONTAINS SUBROUTINE DMUMPS_528( MYID ) IMPLICIT NONE INTEGER MYID BUF_MYID = MYID RETURN END SUBROUTINE DMUMPS_528 SUBROUTINE DMUMPS_61( 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_61 SUBROUTINE DMUMPS_53( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL DMUMPS_2( BUF_CB, SIZE, IERR ) RETURN END SUBROUTINE DMUMPS_53 SUBROUTINE DMUMPS_55( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL DMUMPS_2( BUF_SMALL, SIZE, IERR ) RETURN END SUBROUTINE DMUMPS_55 SUBROUTINE DMUMPS_54( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL DMUMPS_2( BUF_LOAD, SIZE, IERR ) RETURN END SUBROUTINE DMUMPS_54 SUBROUTINE DMUMPS_58( IERR ) IMPLICIT NONE INTEGER IERR CALL DMUMPS_3( BUF_LOAD, IERR ) RETURN END SUBROUTINE DMUMPS_58 SUBROUTINE DMUMPS_620() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE DMUMPS_620 SUBROUTINE DMUMPS_617(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_617 SUBROUTINE DMUMPS_57( IERR ) IMPLICIT NONE INTEGER IERR CALL DMUMPS_3( BUF_CB, IERR ) RETURN END SUBROUTINE DMUMPS_57 SUBROUTINE DMUMPS_59( IERR ) IMPLICIT NONE INTEGER IERR CALL DMUMPS_3( BUF_SMALL, IERR ) RETURN END SUBROUTINE DMUMPS_59 SUBROUTINE DMUMPS_2( 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 DMUMPS_2 SUBROUTINE DMUMPS_3( 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 on SGI' 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 DMUMPS_3 SUBROUTINE DMUMPS_66( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, COMPRESSCB, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT 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_79( 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 NBROWS_PACKET = SIZE_AV_REALS / LCONT 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 DMUMPS_4( 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 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 DMUMPS_1( 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_66 SUBROUTINE DMUMPS_72( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, CB, SOL, & DEST, COMM, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR DOUBLE PRECISION CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) DOUBLE PRECISION SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) 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( 4, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_DOUBLE_PRECISION, COMM, & SIZE2, IERR ) SIZE = SIZE1 + SIZE2 CALL DMUMPS_4( 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 ) 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 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 DMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_72 SUBROUTINE DMUMPS_78( NRHS, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS, NODE1, NODE2, NCB, LONG INTEGER IW( max( 1, LONG ) ) DOUBLE PRECISION W( max( 1, LDW * NRHS ) ) 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( 2+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS*LONG, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR ) END IF SIZE = SIZE1 + SIZE2 CALL DMUMPS_4( 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 ) END IF 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 ) DO K=1, NRHS CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) END DO END IF CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), IERR ) IF ( SIZE .NE. POSITION ) CALL DMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_78 SUBROUTINE DMUMPS_62( I, DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER I INTEGER DEST, TAG, COMM, IERR 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 DMUMPS_4( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN write(6,*) ' Internal error in DMUMPS_62', & ' 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 ) CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR ) RETURN END SUBROUTINE DMUMPS_62 SUBROUTINE DMUMPS_469(FLAG) LOGICAL FLAG LOGICAL FLAG1, FLAG2, FLAG3 CALL DMUMPS_468( BUF_SMALL, FLAG1 ) CALL DMUMPS_468( BUF_CB, FLAG2 ) CALL DMUMPS_468( BUF_LOAD, FLAG3 ) FLAG = FLAG1 .AND. FLAG2 .AND. FLAG3 RETURN END SUBROUTINE DMUMPS_469 SUBROUTINE DMUMPS_468( B, FLAG ) TYPE ( DMUMPS_COMM_BUFFER_TYPE ) :: B LOGICAL :: FLAG INTEGER SIZE_AVAIL CALL DMUMPS_79(B, SIZE_AVAIL) FLAG = ( B%HEAD == B%TAIL ) RETURN END SUBROUTINE DMUMPS_468 SUBROUTINE DMUMPS_79( 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_79 SUBROUTINE DMUMPS_4( B, IPOS, IREQ, MSG_SIZE, IERR, & NDEST , PDEST & ) IMPLICIT NONE TYPE ( DMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER, INTENT(IN) :: MSG_SIZE INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR 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 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 DMUMPS_4 SUBROUTINE DMUMPS_1( 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 DMUMPS_1 SUBROUTINE DMUMPS_68( & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, & NASS, NSLAVES, LIST_SLAVES, & DEST, NFRONT, COMM, IERR ) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER INODE INTEGER NLIG, NCOL, NASS, NSLAVES INTEGER NBPROCFILS, DEST INTEGER ILIG( NLIG ) INTEGER ICOL( NCOL ) INTEGER LIST_SLAVES( NSLAVES ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER SIZE, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE = ( 6 + NLIG + NCOL + NSLAVES + 1 ) * SIZEofINT IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -2 RETURN END IF CALL DMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS 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 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 ) THEN WRITE(*,*) 'Error in DMUMPS_68 :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, MPI_PACKED, & DEST, MAITRE_DESC_BANDE, COMM, & BUF_CB%CONTENT( IREQ ), IERR ) RETURN END SUBROUTINE DMUMPS_68 SUBROUTINE DMUMPS_70( 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 ( ( KEEP(48).NE. 0 ).AND.(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_79( 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 DMUMPS_4( 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 ( ( KEEP(48).NE. 0 ).AND.(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 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 DMUMPS_1( 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_70 SUBROUTINE DMUMPS_67(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_617(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_729( 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_79( 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*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 ! defined(DBG_SMB3) 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 #endif CALL DMUMPS_4( 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 IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 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( 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_47( & 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_47( & 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_67" 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_618( & 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 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 DMUMPS_1( 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_67 SUBROUTINE DMUMPS_71( & 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF CALL DMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST & ) IF (IERR .LT. 0 ) THEN RETURN ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN 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 ) = NCBSON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF (( NSLAVES.GT.0 ) .AND. (KEEP(48).NE.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_71 :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) ENDIF CALL DMUMPS_79( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE ) THEN IERR = -1 RETURN END IF DO IDEST= 1, NDEST CALL MUMPS_49( & 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF ( MYID .NE. DEST( IDEST ) ) THEN CALL DMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST(IDEST) & ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Problem in DMUMPS_4: IERR<0' CALL MUMPS_ABORT() END IF IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 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 ) = TROW_SIZE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF (( NSLAVES.GT.0 ) .AND. (KEEP(48).NE.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 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_71 SUBROUTINE DMUMPS_65( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL, & PDEST, NDEST, KEEP50, NB_BLOC_FAC, COMM, IERR ) IMPLICIT NONE INTEGER INODE, NCOL, NPIV, FPERE, NFRONT, NDEST INTEGER IPIV( NPIV ) DOUBLE PRECISION VAL( NFRONT, * ) INTEGER PDEST( NDEST ) INTEGER KEEP50, NB_BLOC_FAC, COMM, IERR LOGICAL LASTBL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE, & IDEST, IPOSMSG, I INTEGER NPIVSENT INTEGER SSS, SS2 IERR = 0 IF ( LASTBL ) THEN IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF ELSE IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF END IF SIZE2 = 0 IF (NPIV.GT.0) & CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR ) SIZE = SIZE1 + SIZE2 CALL DMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & NDEST , PDEST & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES) THEN SSS = 0 IF ( LASTBL ) THEN IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) END IF ELSE IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) END IF END IF IF (NPIV.GT.0) & CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_DOUBLE_PRECISION, & COMM, SS2, IERR ) SSS = SSS + SS2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF 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 ), SIZE, & POSITION, COMM, IERR ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) IF ( LASTBL .or. KEEP50.ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END IF IF ( LASTBL .AND. KEEP50 .NE. 0 ) THEN CALL MPI_PACK( NDEST, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) IF ( NPIV.GT.0) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NCOL, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END DO ENDIF DO IDEST = 1, NDEST IF ( KEEP50.eq.0) THEN CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR ) ELSE CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR ) END IF END DO SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL DMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_65 SUBROUTINE DMUMPS_64( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU, & NDEST, PDEST, COMM, IERR ) IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE DOUBLE PRECISION UIP21K( NPIV, NCOLU ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE, & IDEST, IPOSMSG, SSS, SS2 IERR = 0 CALL MPI_PACK_SIZE( 6 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR ) SIZE = SIZE1 + SIZE2 IF (SIZE.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR ) CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_DOUBLE_PRECISION, & COMM, SS2, IERR ) SSS = SSS+SS2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF CALL DMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, 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 ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( UIP21K, abs(NPIV) * NCOLU, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) DO IDEST = 1, NDEST 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 SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL DMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_64 SUBROUTINE DMUMPS_648( 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_79( 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 CALL DMUMPS_4( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF 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 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:Sizeid%ISTEP_TO_INIV2 CAND_LOAD=>id%CANDIDATES ND_LOAD=>id%ND_STEPS KEEP_LOAD=>id%KEEP KEEP =>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 = KEEP(69) IF ( KEEP(47) .le. 0 .OR. KEEP(47) .gt. 4 ) THEN write(*,*) "Internal error 1 in DMUMPS_185" CALL MUMPS_ABORT() END IF CHK_LD=dble(0) BDC_MEM = ( KEEP(47) >= 2 ) BDC_POOL = ( KEEP(47) >= 3 ) BDC_SBTR = ( KEEP(47) >= 4 ) BDC_M2_MEM = ( ( KEEP(80) == 2 .OR. KEEP(80) == 3 ) & .AND. KEEP(47) == 4 ) BDC_M2_FLOPS = ( KEEP(80) == 1 & .AND. KEEP(47) .GE. 1 ) BDC_MD = (KEEP(86)==1) SBTR_WHICH_M = KEEP(90) REMOVE_NODE_FLAG=.FALSE. REMOVE_NODE_FLAG_MEM=.FALSE. REMOVE_NODE_COST_MEM=dble(0) REMOVE_NODE_COST=dble(0) IF (KEEP(80) .LT. 0 .OR. KEEP(80)>3) THEN WRITE(*,*) "Unimplemented KEEP(80) Strategy" CALL MUMPS_ABORT() ENDIF IF ((KEEP(80) == 2 .OR. KEEP(80)==3 ).AND. KEEP(47).NE.4) & THEN WRITE(*,*) "Internal error 3 in DMUMPS_185" CALL MUMPS_ABORT() END IF IF (KEEP(81) == 1 .AND. KEEP(47) < 2) THEN WRITE(*,*) "Internal error 2 in DMUMPS_185" CALL MUMPS_ABORT() ENDIF BDC_POOL_MNG = ((KEEP(81) == 1).AND.(KEEP(47) >= 2)) IF(KEEP(76).EQ.4)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST ENDIF IF(KEEP(76).EQ.5)THEN COST_TRAV=>id%COST_TRAV ENDIF IF(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 ALLOCATE(NIV2(id%NSLAVES), NB_SON(KEEP(28)), & POOL_NIV2(100),POOL_NIV2_COST(100), & stat=allocok) NB_SON=id%NE_STEPS NIV2=dble(0) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in DMUMPS_185' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES + 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_185' 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_185' 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_185' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF LU_USAGE=dble(0) MD_MEM=int(0,8) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN ALLOCATE(CB_COST_MEM(2*2000*id%NSLAVES), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in DMUMPS_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF SBTR_CUR = dble(0) SBTR_MEM = dble(0) END IF CALL MUMPS_546(K34_LOC,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_185' id%INFO(1) = -13 id%INFO(2) = LBUF_LOAD_RECV RETURN ENDIF BUF_LOAD_SIZE = BUF_LOAD_SIZE * 20 CALL DMUMPS_54( 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_425(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_460( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEMORY_MD),dble(0) ,MYID, IERR ) WHAT=9 MEMORY_SENT = dble(LA-MAX_SURF_MASTER)-MAX_SBTR & - max( dble(LA) * dble(3) / dble(100), & dble(2) * dble(max(KEEP(5),KEEP(6))) * dble(KEEP(127))) IF (KEEP(12) > 25) THEN MEMORY_SENT = MEMORY_SENT - & dble(KEEP(12))*0.2d0*dble(LA)/100.0d0 ENDIF TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL DMUMPS_460( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MEMORY_SENT, & dble(0),MYID, IERR ) ENDIF RETURN END SUBROUTINE DMUMPS_185 SUBROUTINE DMUMPS_190( CHECK_FLOPS,PROCESS_BANDE, & INC_LOAD, KEEP,KEEP8 ) USE DMUMPS_COMM_BUFFER 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 (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_77( 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, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_190",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_190 SUBROUTINE DMUMPS_471( SSARBR, & PROCESS_BANDE_ARG, MEM_VALUE, NEW_LU, INC_MEM_ARG, & KEEP,KEEP8,LRLU) USE DMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_VALUE, INC_MEM_ARG, NEW_LU,LRLU 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 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_471." 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 #if defined(STATS_DYNAMIC_MEMORY) WRITE(*,*)MYID,': end of Incoherent state at time=', & MPI_WTIME()-TIME_REF #endif 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. #if defined(STATS_DYNAMIC_MEMORY) WRITE(*,*)MYID,': Begin of Incoherent state (1) at time=', & MPI_WTIME()-TIME_REF #endif 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_471', & 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.1d0*dble(LRLU))))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.1d0*dble(LRLU))))THEN IF ( abs( TMP_MEM-DM_LAST_MEM_SENT) > & DM_THRES_MEM ) THEN IERR = 0 SEND_MEM = TMP_MEM #endif 111 CONTINUE CALL DMUMPS_77( & 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,IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_471",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_471 INTEGER FUNCTION DMUMPS_186( 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_426(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_186 = NLESS RETURN END FUNCTION DMUMPS_186 SUBROUTINE DMUMPS_189(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_558(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_189 SUBROUTINE DMUMPS_183( INFO1, IERR ) USE DMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER, intent(in) :: INFO1 INTEGER, intent(out) :: IERR IERR=0 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_58( IERR ) CALL DMUMPS_150( MYID, COMM_LD, & BUF_LOAD_RECV, LBUF_LOAD_RECV, & LBUF_LOAD_RECV_BYTES ) DEALLOCATE(BUF_LOAD_RECV) END SUBROUTINE DMUMPS_183 #if defined (LAMPORT_) RECURSIVE SUBROUTINE DMUMPS_467(COMM, KEEP) #else SUBROUTINE DMUMPS_467(COMM, KEEP) #endif IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MSGTAG, MSGLEN, MSGSOU,COMM INTEGER KEEP(500) 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(65)=KEEP(65)+1 MSGTAG = STATUS( MPI_TAG ) MSGSOU = STATUS( MPI_SOURCE ) IF ( MSGTAG .NE. UPDATE_LOAD) THEN write(*,*) "Internal error 1 in DMUMPS_467", & 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_467", & 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_187( MSGSOU, BUF_LOAD_RECV, & LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES ) GOTO 10 ENDIF RETURN END SUBROUTINE DMUMPS_467 RECURSIVE SUBROUTINE DMUMPS_187 & ( MSGSOU, BUFR, LBUFR, LBUFR_BYTES ) 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_330 INTEGER MUMPS_330 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_819(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_187" 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_187" 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_187" 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_816(INODE_RECEIVED) ELSEIF(BDC_M2_FLOPS) THEN CALL DMUMPS_817(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_330(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_187" 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. & sqrt(epsilon(LOAD_RECEIVED)))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 WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() 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_187' 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_187' 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_187' 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_187" CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE DMUMPS_187 integer function DMUMPS_409 & (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_426(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_409 = nless return end function DMUMPS_409 subroutine DMUMPS_384 & (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_558 NMB_OF_CAND = CAND(SLAVEF+1) if(nslaves_inode.ge.NPROCS .or. & nslaves_inode.gt.NMB_OF_CAND) then write(*,*)'Internal error in DMUMPS_384', & 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_558(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_384 SUBROUTINE DMUMPS_425(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_425 SUBROUTINE DMUMPS_426(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_426 SUBROUTINE DMUMPS_461(MYID, SLAVEF, COMM, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, NSLAVES,INODE) USE DMUMPS_COMM_BUFFER 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 DOUBLE PRECISION MEM_INCREMENT ( NSLAVES ) DOUBLE PRECISION FLOPS_INCREMENT( NSLAVES ) DOUBLE PRECISION CB_BAND( NSLAVES ) IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN WHAT=1 ELSE WHAT=19 ENDIF #if ! defined(OLD_LOAD_MECHANISM) FUTURE_NIV2(MYID+1) = FUTURE_NIV2(MYID+1) - 1 IF ( FUTURE_NIV2(MYID+1) < 0 ) THEN WRITE(*,*) "Internal error in DMUMPS_461" CALL MUMPS_ABORT() ENDIF IF ( FUTURE_NIV2(MYID + 1) == 0 ) THEN 112 CONTINUE CALL DMUMPS_502(COMM,MYID,SLAVEF, & dble(MAX_SURF_MASTER),IERR) IF (IERR == -1 ) THEN CALL DMUMPS_467(COMM_LD, KEEP) GOTO 112 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_461", & IERR CALL MUMPS_ABORT() ENDIF TAB_MAXS(MYID) = TAB_MAXS(MYID) + int(MAX_SURF_MASTER,8) ENDIF #endif IF ( NSLAVES /= TAB_POS(SLAVEF + 2) ) THEN write(*,*) "Error 1 in DMUMPS_461", & 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_524(BDC_MEM, COMM, MYID, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT,IERR) IF ( IERR == -1 ) THEN CALL DMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_461", & 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 RETURN END SUBROUTINE DMUMPS_461 SUBROUTINE DMUMPS_500( & POOL, LPOOL, & PROCNODE, KEEP,KEEP8, SLAVEF, COMM, MYID, STEP, N, & ND, FILS ) USE DMUMPS_COMM_BUFFER 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_330 EXTERNAL MUMPS_330 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_330( 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_460( WHAT, & COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0),MYID, IERR ) POOL_LAST_COST_SENT = COST POOL_MEM(MYID)=COST IF ( IERR == -1 )THEN CALL DMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_500", & IERR CALL MUMPS_ABORT() ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_500 SUBROUTINE DMUMPS_501( & OK,INODE,POOL,LPOOL,MYID,SLAVEF,COMM,KEEP,KEEP8) USE DMUMPS_COMM_BUFFER 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_283,MUMPS_170 LOGICAL MUMPS_283,MUMPS_170 IF((INODE.LE.0).OR.(INODE.GT.N_LOAD)) THEN RETURN ENDIF IF (.NOT.MUMPS_170( & PROCNODE_LOAD(STEP_LOAD(INODE)), NPROCS) & ) THEN RETURN ENDIF IF(MUMPS_283(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_460( & WHAT, COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0),MYID, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 1 in DMUMPS_501", & 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_460( & WHAT, COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0) ,MYID,IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_467(COMM_LD, KEEP) GOTO 112 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 3 in DMUMPS_501", & 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_501 SUBROUTINE DMUMPS_504 & (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_504" 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_558(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_558(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 #if defined (OLD_PART) 887 CONTINUE #endif 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_504" 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_504" 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_504' 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_504' 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_504' 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 #if ! defined (OLD_PART) i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 #if ! defined (PART1_) 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_504' 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 #endif 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 #if ! defined (PART1_) ENDIF #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 ! defined (PART1_) 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 #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 #else DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/ & dble(i)).NE.0)THEN GOTO 555 ENDIF ENDDO 555 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(i)) DO J=1,i IF(NB_ROWS(J)+X.GT.K821/NCB)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & ((K821/NCB)-NB_ROWS(J)) NB_ROWS(J)=(K821/NFRONT) ELSE IF ((TEMP(J)+dble((NB_ROWS(J)+X))* & dble(NFRONT)).GT. & PEAK)THEN AFFECTED=int((PEAK-(TEMP(J)+dble(NB_ROWS(J))* & dble(NFRONT))/dble(NFRONT)) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED NB_ROWS(J)=NB_ROWS(J)+AFFECTED ELSE NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDIF IF(((TEMP(J)+dble(NB_ROWS(J))*dble(NFRONT)) & .GT. PEAK) & .AND.(SMALL_SET.LT.OTHERS))THEN WRITE(*,*)MYID, & ':Internal error 8 in DMUMPS_504' SMALL_SET=SMALL_SET+1 CALL MUMPS_ABORT() ENDIF ENDDO SOMME=dble(0) DO J=1,CHOSEN SOMME=SOMME+NB_ROWS(J) ENDDO IF(ADDITIONNAL_ROWS.NE.0) THEN DO J=1,CHOSEN IF(NB_ROWS(J).LT.0)THEN WRITE(*,*)MYID, & ':Internal error 9 in DMUMPS_504' CALL MUMPS_ABORT() ENDIF IF ((TEMP(J)+dble(NB_ROWS(J)) & *dble(NFRONT)).GT. & PEAK)THEN WRITE(*,*)MYID, & ':Internal error 10 in DMUMPS_504' CALL MUMPS_ABORT() ENDIF IF ((TEMP(J)+dble(NB_ROWS(J)+ & ADDITIONNAL_ROWS)*dble(NFRONT)).GE. & PEAK)THEN AFFECTED=int((PEAK-(TEMP(J)+ & dble(NB_ROWS(J))* & dble(NFRONT))/dble(NFRONT)) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED NB_ROWS(J)=NB_ROWS(J)+AFFECTED IF((TEMP(J)+dble(NFRONT)* & dble(NB_ROWS(J))).GT. & PEAK)THEN WRITE(*,*)MYID, & ':Internal error 11 in DMUMPS_504' CALL MUMPS_ABORT() ENDIF ELSE NB_ROWS(J)=NB_ROWS(J)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 666 ENDDO IF(SMALL_SET.EQ.(NUMBER_OF_PROCS)) THEN NB_ROWS=0 GOTO 887 ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF(NB_ROWS(i)+ADDITIONNAL_ROWS.LT.K821/NFRONT) & THEN NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-(K821/ & NFRONT & -NB_ROWS(i)) NB_ROWS(i)=K821/NFRONT ENDIF i=i+1 ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/dble(i)) & .NE.0)THEN GOTO 372 ENDIF ENDDO 372 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 ENDIF #endif 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_504' CALL MUMPS_ABORT() ENDIF CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*) & 'Internal error 13 in DMUMPS_504' 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_504' 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_504' CALL MUMPS_ABORT() ENDIF END SUBROUTINE DMUMPS_504 SUBROUTINE DMUMPS_518 & (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_442 INTEGER MUMPS_442 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_442(int(NCB,8)*int(KMAX,8),K50,KMAX,NCB) NB_ROWS=0 CALL MUMPS_558(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_511(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_558(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 #if ! defined (OOC_PAR_MEM_SLAVE_SELECT) && ! defined (OOC_PAR_MEM2) CALL MUMPS_503(WHAT, KEEP,KEEP8, NCB, & NFRONT, min(NCB,OTHERS), J, X8) #endif 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_558(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_518' 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_518' 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_518' 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_518' 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_558(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_518' 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_558(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_518' 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_518' CALL MUMPS_ABORT() ENDIF X=X+1 ENDIF ENDDO DO i=CHOSEN+1,NUMBER_OF_PROCS SLAVES_LIST(i)=TEMP_ID(i) ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*)MYID, & ': Internal error 17 in DMUMPS_518', & POS,NCB+1 CALL MUMPS_ABORT() ENDIF END SUBROUTINE DMUMPS_518 SUBROUTINE DMUMPS_520 & (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_508, & MUMPS_170 LOGICAL DMUMPS_508, & MUMPS_170 NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF(KEEP(47).LT.2)THEN WRITE(*,*)'DMUMPS_520 must & be called with K47>=2' CALL MUMPS_ABORT() ENDIF IF((INODE.GT.0).AND.(INODE.LE.N))THEN MEM_COST=DMUMPS_543(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_543(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_170(PROCNODE(STEP(INODE)), & SLAVEF))THEN WRITE(*,*) & 'Internal error 1 in DMUMPS_520' CALL MUMPS_ABORT() ENDIF UPPER=.FALSE. RETURN ENDIF INODE=POOL(LPOOL-2-NBTOP) UPPER=.TRUE. RETURN ENDIF ENDIF UPPER=.TRUE. END SUBROUTINE DMUMPS_520 SUBROUTINE DMUMPS_513(WHAT) IMPLICIT NONE LOGICAL WHAT IF(.NOT.BDC_POOL_MNG)THEN WRITE(*,*)'DMUMPS_513 & 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_513 DOUBLE PRECISION FUNCTION DMUMPS_543( INODE ) IMPLICIT NONE INTEGER INODE,LEVEL,i,NELIM,NFR DOUBLE PRECISION COST EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_330( 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_543=COST RETURN END FUNCTION DMUMPS_543 RECURSIVE SUBROUTINE DMUMPS_515(FLAG,COST,COMM) USE DMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL FLAG DOUBLE PRECISION COST DOUBLE PRECISION TO_BE_SENT EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_460( WHAT, & COMM, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, & TO_BE_SENT, & MYID, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_467(COMM_LD, KEEP_LOAD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_500", & IERR CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE DMUMPS_515 SUBROUTINE DMUMPS_512(INODE,STEP,NSTEPS,PROCNODE,FRERE, & NE,COMM,SLAVEF,MYID,KEEP,KEEP8,N) USE DMUMPS_COMM_BUFFER 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_170,MUMPS_275 LOGICAL MUMPS_170 INTEGER i,NCB,NELIM INTEGER MUMPS_275 INTEGER FATHER_NODE,FATHER,WHAT,IERR EXTERNAL MUMPS_330 INTEGER MUMPS_330 IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*)MYID,': Problem in DMUMPS_512' 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_170(PROCNODE(STEP(FATHER_NODE)), & SLAVEF)) THEN RETURN ENDIF FATHER=MUMPS_275(PROCNODE(STEP(FATHER_NODE)),SLAVEF) IF(FATHER.EQ.MYID)THEN IF(BDC_M2_MEM)THEN CALL DMUMPS_816(FATHER_NODE) ELSEIF(BDC_M2_FLOPS)THEN CALL DMUMPS_817(FATHER_NODE) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN IF(MUMPS_330(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_519(WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB, KEEP(81),MYID, & FATHER, IERR) IF (IERR == -1 ) THEN CALL DMUMPS_467(COMM, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_512", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE END SUBROUTINE DMUMPS_512 SUBROUTINE DMUMPS_514(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_515(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_515(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_514 RECURSIVE SUBROUTINE DMUMPS_816(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_816' 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 POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & DMUMPS_543(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_515(REMOVE_NODE_FLAG_MEM,MAX_M2,COMM_LD) NIV2(1+MYID)=MAX_M2 ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_816 RECURSIVE SUBROUTINE DMUMPS_817(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_817' 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 POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & DMUMPS_542(INODE) POOL_SIZE=POOL_SIZE+1 MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL DMUMPS_515(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_817 DOUBLE PRECISION FUNCTION DMUMPS_542(INODE) INTEGER INODE INTEGER NFRONT,NELIM,i,LEVEL EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_330( PROCNODE_LOAD(STEP_LOAD(INODE)), NPROCS ) COST=dble(0) CALL MUMPS_511(NFRONT,NELIM,NELIM, & KEEP_LOAD(50),LEVEL,COST) DMUMPS_542=COST RETURN END FUNCTION DMUMPS_542 INTEGER FUNCTION DMUMPS_541( 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_541=COST_CB RETURN END FUNCTION DMUMPS_541 SUBROUTINE DMUMPS_533(SLAVEF,NMB_OF_CAND, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, & NSLAVES,INODE) USE DMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, NASS, NSLAVES INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, intent(in) :: NMB_OF_CAND INTEGER, INTENT (IN) :: LIST_SLAVES( NMB_OF_CAND ) INTEGER KEEP(500),INODE INTEGER(8) KEEP8(150) INTEGER allocok DOUBLE PRECISION MEM_COST,FCT_COST DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE ::EMPTY_ARRAY, & DELTA_MD,EMPTY_ARRAY2 INTEGER NBROWS_SLAVE,i,WHAT,IERR,NPROCS_LOC LOGICAL FORCE_CAND MEM_COST=dble(0) FCT_COST=dble(0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. NPROCS_LOC=SLAVEF-1 ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) NPROCS_LOC=NMB_OF_CAND END IF IF(FORCE_CAND)THEN CALL DMUMPS_540(INODE,FCT_COST, & MEM_COST,NPROCS_LOC,NASS) ELSE CALL DMUMPS_540(INODE,FCT_COST, & MEM_COST,SLAVEF-1,NASS) ENDIF DO i=1,SLAVEF IDWLOAD(i)=i-1 ENDDO ALLOCATE(EMPTY_ARRAY(NPROCS_LOC),DELTA_MD(NPROCS_LOC), & EMPTY_ARRAY2(NPROCS_LOC), & stat=allocok) DO i = 1, NSLAVES NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) DELTA_MD( i ) = FCT_COST - dble(NBROWS_SLAVE)* & dble(NASS) END DO IF(FORCE_CAND)THEN DO i=NSLAVES+1,NPROCS_LOC DELTA_MD( i ) = FCT_COST ENDDO ELSE DO i=NSLAVES+1,SLAVEF-1 DELTA_MD( i ) = FCT_COST ENDDO ENDIF WHAT=7 111 CONTINUE CALL DMUMPS_524(.FALSE., COMM_LD, MYID, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NPROCS_LOC, LIST_SLAVES,0, & EMPTY_ARRAY, & DELTA_MD,EMPTY_ARRAY2,WHAT, IERR) IF ( IERR == -1 ) THEN CALL DMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_533", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif DO i = 1, NSLAVES MD_MEM(LIST_SLAVES(i))=MD_MEM(LIST_SLAVES(i))+ & int(DELTA_MD( 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 ENDDO #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif DEALLOCATE(EMPTY_ARRAY) DEALLOCATE(DELTA_MD) END SUBROUTINE DMUMPS_533 SUBROUTINE DMUMPS_540(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_540 SUBROUTINE DMUMPS_819(INODE) IMPLICIT NONE INTEGER INODE INTEGER i,J,SON,NSLAVES_TEMP,POS_TEMP,K INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_275( & 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_819 SUBROUTINE DMUMPS_820(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_820 SUBROUTINE DMUMPS_554(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_554 SUBROUTINE DMUMPS_818(INODE,MAX_MEM,PROC) IMPLICIT NONE INTEGER INODE,PROC INTEGER i,POS,NSLAVES,SLAVE,NCAND,J,NELIM,NCB,NFRONT,SON,K INTEGER allocok EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_818' CALL MUMPS_ABORT() ENDIF ALLOCATE( CONCERNED(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_818' CALL MUMPS_ABORT() ENDIF ALLOCATE( RECV_BUF(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_818' 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_330(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_543(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_330(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_818' 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_818 SUBROUTINE DMUMPS_553(MIN_PROC,POOL, & LPOOL,INODE) IMPLICIT NONE INTEGER INODE,LPOOL,MIN_PROC INTEGER POOL(LPOOL) EXTERNAL MUMPS_275 INTEGER MUMPS_275 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_275(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_275(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_553 SUBROUTINE DMUMPS_555(POOL, LPOOL,KEEP,KEEP8) IMPLICIT NONE INTEGER LPOOL,POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER i,POS EXTERNAL MUMPS_283 LOGICAL MUMPS_283 IF(.NOT.BDC_SBTR) RETURN POS=0 DO i=NB_SUBTREES,1,-1 DO WHILE(MUMPS_283( & 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_555 END MODULE DMUMPS_LOAD mumps-4.10.0.dfsg/src/mumps_io_basic.h0000644000175300017530000002107111562233011020025 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #ifndef MUMPS_IO_BASIC_H #define MUMPS_IO_BASIC_H #include "mumps_compat.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" #ifdef 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) ( (int)(x) >= (x) ? (int)(x) : ( (int)(x) + 1 ) ) typedef struct __mumps_file_struct{ int write_pos; int current_pos; int is_opened; #if ! defined (MUMPS_WIN32) 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) int mumps_flag_open; #else char mumps_flag_open[6]; #endif int mumps_io_current_file_number; int mumps_io_last_file_opened; int mumps_io_nb_file_opened; 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 int* mumps_io_pfile_pointer_array; */ /* extern 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 int mumps_io_current_file_number; */ extern char* mumps_ooc_file_prefix; /* extern char** mumps_io_pfile_name; */ /* extern int mumps_io_current_file_position; */ /* extern int mumps_io_write_pos; */ /* extern int mumps_io_last_file_opened; */ extern int mumps_elementary_data_size; extern int mumps_io_is_init_called; extern int mumps_io_myid; extern int mumps_io_max_file_size; /* extern int mumps_io_nb_file; */ extern int mumps_io_flag_async; extern int mumps_io_k211; /* extern int mumps_flag_open; */ extern int directio_flag; extern int mumps_directio_flag; extern int mumps_io_nb_file_type; /* Exported functions */ int mumps_set_file(int type,int file_number_arg); void mumps_update_current_file_position(mumps_file_struct* file_arg); int mumps_compute_where_to_write(const double to_be_written,const int type,long long vaddr,size_t already_written); int mumps_prepare_pointers_for_write(double to_be_written,int * pos_in_file, int * file_number,const int type,long long vaddr,size_t already_written); int mumps_io_do_write_block(void * address_block,long long block_size,int * type,long long vaddr,int * ierr); int mumps_io_do_read_block(void * address_block,long long block_size,int * type,long long vaddr,int * ierr); int mumps_compute_nb_concerned_files(long long block_size,int * nb_concerned_files,long long vaddr); MUMPS_INLINE int mumps_gen_file_info(long long vaddr, int * pos, int * file); int mumps_free_file_pointers(int* step); int mumps_init_file_structure(int *_myid, long long *total_size_io,int *size_element,int *nb_file_type,int *flag_tab); int mumps_init_file_name(char* mumps_dir,char* mumps_file,int* mumps_dim_dir,int* mumps_dim_file,int* _myid); void mumps_io_init_file_struct(int* nb,int which); int mumps_io_alloc_file_struct(int* nb,int which); int mumps_io_get_nb_files(int* nb_files, const int* type); int mumps_io_get_file_name(int* indice,char* name,int* length,int* type); int mumps_io_alloc_pointers(int * nb_file_type, int * dim); int mumps_io_init_vars(int* myid_arg,int* size_element,int* async_arg); int mumps_io_set_file_name(int* indice,char* name,int* length,int* type); int mumps_io_open_files_for_read(); int mumps_io_set_last_file(int* dim,int* type); int mumps_io_write__(void *file, void *loc_add, size_t write_size, int where,int type); #if ! defined (MUMPS_WIN32) int mumps_io_write_os_buff__(void *file, void *loc_add, size_t write_size, int where); int mumps_io_write_direct_io__(void *file, void *loc_addr, size_t write_size, int where,int type); int mumps_io_flush_write__(int type); #else int mumps_io_write_win32__(void *file, void *loc_add, size_t write_size, int where); #endif int mumps_io_read__(void * file,void * loc_addr,size_t size,int local_offset,int type); #if ! defined (MUMPS_WIN32) int mumps_io_read_os_buff__(void * file,void * loc_addr,size_t size,int local_offset); int mumps_io_read_direct_io__(void * file,void * loc_addr,size_t size,int local_offset,int type); #else int mumps_io_read_win32__(void * file,void * loc_addr,size_t size,int local_offset); #endif int mumps_compute_file_size(void *file,size_t *size); #if ! defined (MUMPS_WIN32) && ! defined (WITHOUT_PTHREAD) # ifdef WITH_PFUNC int mumps_io_protect_pointers(); int mumps_io_unprotect_pointers(); int mumps_io_init_pointers_lock(); int mumps_io_destroy_pointers_lock(); # endif /* WITH_PFUNC */ #endif /* MUMPS_WIN32 */ #endif /* MUMPS_IO_BASIC_H */ mumps-4.10.0.dfsg/src/smumps_ooc_buffer.F0000644000175300017530000004462211562233065020527 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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 INTEGER IO_STRAT 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_689(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_689 SUBROUTINE SMUMPS_707(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL SMUMPS_696(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_689(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE SMUMPS_707 SUBROUTINE SMUMPS_675(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_707(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL SMUMPS_707(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_675 SUBROUTINE SMUMPS_696(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_677(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_677(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_696 SUBROUTINE SMUMPS_669(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_731(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_686() ELSE CALL SMUMPS_685() ENDIF RETURN END SUBROUTINE SMUMPS_669 SUBROUTINE SMUMPS_659() 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_659 SUBROUTINE SMUMPS_685() 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_689(OOC_FCT_TYPE_LOC) END SUBROUTINE SMUMPS_685 SUBROUTINE SMUMPS_678(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_707(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_678 SUBROUTINE SMUMPS_686() 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_689(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE SMUMPS_686 SUBROUTINE SMUMPS_706(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_696(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL SMUMPS_689(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_706 SUBROUTINE SMUMPS_709 (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_709 SUBROUTINE SMUMPS_653( 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_653: 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_707(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL SMUMPS_706(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'SMUMPS_653: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL SMUMPS_709 (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_653 END MODULE SMUMPS_OOC_BUFFER mumps-4.10.0.dfsg/src/mumps_io.h0000644000175300017530000001770611562233011016676 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #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 int MUMPS_OOC_STORE_PREFIXLEN=-1; static char MUMPS_OOC_STORE_TMPDIR[MUMPS_OOC_TMPDIR_MAX_LENGTH]; static 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 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-4.10.0.dfsg/src/tools_common_mod.F0000644000175300017530000001032111562233014020340 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE TOOLS_COMMON INTERFACE MUMPS_733 SUBROUTINE MUMPS_754(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) INTEGER, POINTER :: ARRAY(:) INTEGER :: MINSIZE, LP INTEGER :: INFO(:) LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE, MEMCNT END SUBROUTINE MUMPS_754 SUBROUTINE MUMPS_752(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) REAL(kind(1.D0)), POINTER :: ARRAY(:) INTEGER :: MINSIZE, LP INTEGER :: INFO(:) LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE, MEMCNT END SUBROUTINE MUMPS_752 SUBROUTINE MUMPS_750(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) REAL(kind(1.E0)), POINTER :: ARRAY(:) INTEGER :: MINSIZE, LP INTEGER :: INFO(:) LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE, MEMCNT END SUBROUTINE MUMPS_750 SUBROUTINE MUMPS_753(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) COMPLEX(kind((1.D0,1.D0))), POINTER :: ARRAY(:) INTEGER :: MINSIZE, LP INTEGER :: INFO(:) LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE, MEMCNT END SUBROUTINE MUMPS_753 SUBROUTINE MUMPS_751(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) COMPLEX(kind((1.E0,1.E0))), POINTER :: ARRAY(:) INTEGER :: MINSIZE, LP INTEGER :: INFO(:) LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE, MEMCNT END SUBROUTINE MUMPS_751 END INTERFACE END MODULE mumps-4.10.0.dfsg/src/smumps_part2.F0000644000175300017530000074344611562233065017460 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE SMUMPS_152(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_729( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) ) IF (KEEP(216).eq.3) THEN SIZFR_BLOCK_EFF=SIZFR_BLOCK ELSE CALL SMUMPS_628( 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 ENDIF MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL SMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLU) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 IPOSSHIFT = IWPOSCB + KEEP(IXSZ) SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_729( 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) LRLUS = LRLUS + SIZFR_BLOCK_EFF CALL SMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLU) END IF RETURN END SUBROUTINE SMUMPS_152 SUBROUTINE SMUMPS_144( 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) USE SMUMPS_OOC 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), & PTRARW(LPTRAR), PTRAIW(LPTRAR), & ND( KEEP(28) ), FRERE( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) 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(max(1,KEEP(13))) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, & NBTLKJ, IBEG_BLOCK INTEGER(8) :: POSELT INTEGER NASS, NEL1, IEND, IOLDPS, dummy, allocok LOGICAL LASTBL REAL UUTEMP INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INCLUDE 'mumps_headers.h' EXTERNAL SMUMPS_224, SMUMPS_233, & SMUMPS_225, SMUMPS_232, & SMUMPS_294, & SMUMPS_44 LOGICAL STATICMODE REAL SEUIL_LOC 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 IBEG_BLOCK=1 dummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5),NASS ) ENDIF NBTLKJ = NBOLKJ ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, & ' integers' IFLAG = -13 IERROR =NASS GO TO 490 END IF IF (KEEP(201).EQ.1) THEN CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_U 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 50 CONTINUE IBEGKJI = IBEG_BLOCK CALL SMUMPS_224(NFRONT,NASS,IBEGKJI, NASS, IPIV, & 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) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ENDIF IF (INOPV.GE.1) THEN LASTBL = (INOPV.EQ.1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL SMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, NFRONT, & IBEGKJI, IEND, IPIV, NASS,LASTBL, dummy, & & 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, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (INOPV.EQ.1) GO TO 500 IF (INOPV.EQ.2) THEN CALL SMUMPS_233(IBEG_BLOCK,NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP(IXSZ)) GOTO 50 ENDIF NPVW = NPVW + 1 IF (NASS.LE.1) THEN IFINB = -1 ELSE CALL SMUMPS_225(IBEG_BLOCK, & NFRONT, NASS, N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),KEEP(IXSZ)) ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 50 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN LASTBL = (IFINB.EQ.-1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL SMUMPS_294(COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, NFRONT, & IBEGKJI, IEND, IPIV, NASS, LASTBL, dummy, & & 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, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (IFINB.EQ.(-1)) GOTO 500 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV CALL SMUMPS_232(A,LA, & NFRONT,NPIV,NASS,POSELT,NBTLKJ) IF (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV TYPEFile = TYPEF_BOTH_LU LAST_CALL= .FALSE. CALL SMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG<0) RETURN ENDIF GO TO 50 490 CONTINUE CALL SMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE DEALLOCATE( IPIV ) IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) TYPEFile = TYPEF_BOTH_LU LAST_CALL = .TRUE. CALL SMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG<0) RETURN CALL SMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE SMUMPS_144 SUBROUTINE SMUMPS_176( 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, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE SMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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(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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) REAL DBLARR( max(1,KEEP(13)) ) 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 INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_73(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'SMUMPS_73' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL SMUMPS_270( 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, 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_275(PROCNODE_STEPS(STEP(IN)),SLAVEF) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL SMUMPS_74(IN, NELIM_SENT, & PDEST, COMM, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'SMUMPS_73' CALL MUMPS_ABORT() endif ELSE CALL SMUMPS_271( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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 CALL SMUMPS_626( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL SMUMPS_152( .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_176 SUBROUTINE SMUMPS_268(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, NBPROCFILS, & IPOOL, LPOOL, LEAF, KEEP,KEEP8, 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) 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 NBPROCFILS( 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_330 EXTERNAL MUMPS_330 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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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 + 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 ( ( KEEP(48).NE. 0 ).AND.(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_330(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_507(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE SMUMPS_268 SUBROUTINE SMUMPS_242(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF) USE SMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST 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_62( DATA(1), DEST, TAG, & COMMW, IERR ) ELSE WRITE(*,*) 'Error : bad argument to SMUMPS_242' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE SMUMPS_242 SUBROUTINE SMUMPS_44( MYID, SLAVEF, COMM ) INTEGER MYID, SLAVEF, COMM INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) CALL SMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF ) RETURN END SUBROUTINE SMUMPS_44 SUBROUTINE SMUMPS_464( K34, K35, K16, K10 ) IMPLICIT NONE INTEGER, INTENT(OUT) :: K34, K35, K10, K16 INTEGER SIZE_INT, SIZE_REAL_OR_DOUBLE INTEGER I(2) REAL R(2) 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_464 SUBROUTINE SMUMPS_20( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP) IMPLICIT NONE REAL DKEEP(30) REAL CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(40), KEEP(500), SYM, PAR, NSLAVES INTEGER INFO(40), INFOG(40) INTEGER(8) KEEP8(150) INTEGER LWK_USER C Let $A_{preproc}$ be the preprocessed matrix to be factored (see 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:30) = 0.0E0 KEEP( 50 ) = SYM IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 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 KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN KEEP(46) = 1 END IF ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 ICNTL(5) = 0 IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF ICNTL(7) = 7 ICNTL(8) = 77 ICNTL(9) = 1 ICNTL(10) = 0 ICNTL(11) = 0 IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF ICNTL(13) = 0 IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ELSE IF (NSLAVES .GT. 4) THEN ICNTL(14) = 30 ELSE ICNTL(14) = 20 END IF ICNTL(15) = 0 ICNTL(16) = 0 ICNTL(17) = 0 ICNTL(18) = 0 ICNTL(19) = 0 ICNTL(20) = 0 ICNTL(21) = 0 ICNTL(22) = 0 ICNTL(23) = 0 ICNTL(24) = 0 ICNTL(27) = -8 ICNTL(28) = 1 ICNTL(29) = 0 ICNTL(39) = 1 ICNTL(40) = 0 KEEP(12) = 0 KEEP(11) = 2147483646 KEEP(24) = 18 KEEP(68) = 0 KEEP(36) = 1 KEEP(1) = 8 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 IF (NSLAVES.GE.128) KEEP(62)=200 IF (NSLAVES.GE.128) KEEP(9)=800 IF (NSLAVES.GE.256) KEEP(9)=900 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 48 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 100 IF (NSLAVES.GE.128) KEEP(62)=150 IF (NSLAVES.GE.64) KEEP(9)=800 IF (NSLAVES.GE.128) KEEP(9)=900 END IF KEEP(63) = 60 KEEP(48) = 5 KEEP(17) = 0 CALL SMUMPS_464( KEEP(34), KEEP(35), & KEEP(16), KEEP(10) ) #if defined(SP_) KEEP( 51 ) = 70 #else KEEP( 51 ) = 48 #endif 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) = 10 KEEP(69) = 4 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 30 KEEP(79) = 0 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) = 5 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 #else KEEP(99)=4 #endif KEEP(100)=0 KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 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 IF(NSLAVES.LE.8)THEN KEEP(238)=12 ELSE KEEP(238)=7 ENDIF KEEP(234)= 1 DKEEP(3)=-5.0E0 KEEP(242) = 1 KEEP(250) = 1 RETURN END SUBROUTINE SMUMPS_20 SUBROUTINE SMUMPS_786(id, LP) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN IF (LP.GT.0) & write(LP,*) 'Warning KEEP(72) = 1 !!!!!!!!!! ' 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 ELSE IF (id%KEEP(72)==2) THEN IF (LP.GT.0) & write(LP,*)' OOC setting to reduce stack memory', & ' KEEP(72)=', id%KEEP(72) id%KEEP(85)=2 id%KEEP(85)=-10000 id%KEEP(62) = 10 id%KEEP(210) = 1 id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 id%KEEP(102) = 110 id%KEEP(213) = 121 END IF RETURN END SUBROUTINE SMUMPS_786 SUBROUTINE SMUMPS_195(N, NZ, IRN, ICN, LIW, IKEEP, PTRAR, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N,NZ,LIW,IORD,SIZE_SCHUR, NSLAVES INTEGER PTRAR(N,4), NFSIZ(N), FILS(N), FRERE(N) INTEGER IKEEP(N,3) INTEGER LISTVAR_SCHUR(SIZE_SCHUR) INTEGER INFO(40), ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) TYPE (SMUMPS_STRUC) :: id INTEGER IRN(NZ), ICN(NZ) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER IERR INTEGER K,I,L1,L2,IWFR,NCMPA,LLIW, IN, IFSON INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER MedDens, NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: HEAD INTEGER NUMFLAG INTEGER OPT_METIS_SIZE INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS 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 EXTERNAL MUMPS_197, SMUMPS_198, & SMUMPS_199, SMUMPS_351, & SMUMPS_557, SMUMPS_201 #if defined(OLDDFS) EXTERNAL SMUMPS_200 #endif EXTERNAL SMUMPS_623 EXTERNAL SMUMPS_547, SMUMPS_550, & SMUMPS_556 ALLOCATE( IW ( LIW ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW RETURN ENDIF LLIW = LIW - 2*N - 1 L1 = LLIW + 1 L2 = L1 + N LP = ICNTL(1) MP = ICNTL(3) PROK = (MP.GT.0) 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, NZ, LIW, INFO(1) K = min0(10,NZ) IF (LDIAG.EQ.4) K = NZ IF (K.GT.0) WRITE (MP,99998) (IRN(I),ICN(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 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) 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 CALL SMUMPS_623(N,NCMP,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), MedDens, NBQD, AvgDens, & LISTVAR_SCHUR, SIZE_SCHUR, & FRERE,FILS) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif CALL SMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), MedDens, NBQD, AvgDens) #if defined(metis) || defined(parmetis) 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 SMUMPS_701( N, KEEP(50), NSLAVES, IORD, & symmetry, MedDens, 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_195 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_195 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_556( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) ENDIF IF ( IORD .NE. 1 ) THEN IF(COMPRESS .GE. 1) THEN CALL SMUMPS_547( & N,NZ, IRN, ICN, PIV, & NCMP, IW(1), LLIW, IW(L2),PTRAR(1,2),PTRAR, & IW(L1), FILS, IWFR, & IERROR, KEEP,KEEP8, ICNTL) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 DEALLOCATE (IW) RETURN 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 K=1,NZ J = ICN(K) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(K) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N RETURN 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 (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' CALL SMUMPS_351 & (N,NZ,IRN, ICN, IW(1), LLIW, IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & MedDens, NBQD, AvgDens) 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 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 ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_162(N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & 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 IF(COMPRESS .EQ. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO CALL MUMPS_PORDF_WND(NCMP, IWFR-1, IW(L2), IW, & IW(L1), NCMPA, N) CALL SMUMPS_548(NCMP,IW(L2),IW(L1),FILS) CALL SMUMPS_549(NCMP,IW(L2),IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ELSE CALL MUMPS_PORDF(NCMP, IWFR-1, IW(L2), IW(1), & IW(L1), NCMPA) ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 RETURN ENDIF #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH(NCMP, LLIW, IW(L2), IWFR, & PTRAR(1,2), IW(1), IW(L1), IKEEP, & IKEEP(1,2), NCMPA) IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out SCTOCH, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 3 RETURN ENDIF IF (COMPRESS .EQ. 1) THEN CALL SMUMPS_548(NCMP,IW(L2),IW(L1),FILS) CALL SMUMPS_549(NCMP,IW(L2),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( HEAD ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 RETURN ENDIF IF(COMPRESS .GE. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO ELSE IW(L1) = -1 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_337(NCMP, NBBUCK, LLIW, IW(L2), & IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_560(NCMP, NBBUCK, LLIW, IW(L2), & IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD, & NFSIZ, FRERE) ENDIF DEALLOCATE(HEAD) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( HEAD ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N RETURN ENDIF THRESH = 1 IVersion = 2 IF(COMPRESS .EQ. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IW(L1) = -1 TOTEL = N ENDIF CALL MUMPS_421(TOTEL,IVersion, THRESH, HEAD, & NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), & IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3)) DEALLOCATE(HEAD) ELSE CALL MUMPS_197(NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL SMUMPS_550(N,NCMP,KEEP(94),KEEP(93), & PIV,IKEEP(1,1),IKEEP(1,2)) COMPRESS = -1 ENDIF ENDIF #if defined(metis) || defined(parmetis) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS ' ENDIF 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 RETURN ENDIF OPTIONS_METIS(1) = 0 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FILS(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FILS(I) = 1 ENDDO CALL METIS_NODEWND(NCMP, IW(L2), IW(1),FILS, & NUMFLAG, OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) ELSE CALL METIS_NODEND(NCMP, IW(L2), IW(1), NUMFLAG, & OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) ENDIF DEALLOCATE (OPTIONS_METIS) IF ( COMPRESS_SCHUR ) THEN CALL SMUMPS_622( & N, NCMP, IKEEP(1,1),IKEEP(1,2), & LISTVAR_SCHUR, SIZE_SCHUR, FILS) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL SMUMPS_550(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) THEN IF ( COMPRESS .EQ. -1 ) THEN CALL SMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & MedDens, NBQD, AvgDens) INFO(8) = symmetry ENDIF COMPRESS = 0 ALLOCATE( HEAD ( 2*N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 2*N RETURN 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 =.TRUE. CALL MUMPS_422(THRESH, HEAD, & N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW, & IW(L1), HEAD(N+1), & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & IKEEP(1,1), LISTVAR_SCHUR, ITEMP, AGG6) DEALLOCATE(HEAD) ELSE CALL SMUMPS_198(N, NZ, IRN, ICN, IKEEP, IW(1), & LLIW, IW(L2), & PTRAR(1,2), IW(L1), IWFR, & INFO(1),INFO(2), KEEP(11), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 CALL SMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & PTRAR, NCMPA, ITEMP) ELSE CALL SMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & PTRAR, NCMPA, SIZE_SCHUR) 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_200 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else CALL SMUMPS_557 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, PTRAR, INFO(6), FILS, FRERE, & PTRAR(1,3), NEMIN, PTRAR(1,4), KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1) #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_201(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_209( 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_510(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 IF ( huge(KEEP8(79)) / K79REF + 1_8 .GE. int(NSLAVES,8) ) THEN KEEP8(79)=huge(KEEP8(79)) ELSE KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF 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_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG,INFO(1),INFO(2)) IF (INFO(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) & .AND. (KEEP(60).EQ.0) IF (SPLITROOT) THEN CALL SMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG,INFO(1),INFO(2)) IF (INFO(1).LT.0) RETURN 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,99986) (PTRAR(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99985) (PTRAR(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99984) (PTRAR(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 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) GOTO 90 90 CONTINUE DEALLOCATE(IW) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NZ 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)=', 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)) 99986 FORMAT ('PTRAR(.,1)=', 10I6/(12X, 10I6)) 99985 FORMAT ('PTRAR(.,2)=', 10I6/(12X, 10I6)) 99984 FORMAT ('PTRAR(.,3)=', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE SMUMPS_195 SUBROUTINE SMUMPS_199(N,IPE,IW, LW, IWFR, IPS, IPV, NV, FLAG, & NCMPA, SIZE_SCHUR) INTEGER N,LW,IWFR,NCMPA,SIZE_SCHUR INTEGER FLAG(N) INTEGER IPS(N), IPV(N) INTEGER IW(LW), NV(N), IPE(N) INTEGER I,J,ML,MS,ME,IP,MINJS,IE,KDUMMY,JP INTEGER LN,JP1,JS,LWFR,JP2,JE 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) GO TO 60 LN = IW(JP) DO 50 JP1=1,LN JP = JP + 1 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 - JP1 CALL SMUMPS_194(N, IPE, IW, IP-1, 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 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min0(MINJS,IPS(JS)+0) IWFR = IWFR + 1 50 CONTINUE 60 IPE(IE) = -ME 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 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = IWFR - IP IPE(ME) = IP IWFR = IWFR + 1 100 CONTINUE IF (SIZE_SCHUR == 0) RETURN 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) GO TO 160 LN = IW(JP) 160 IPE(IE) = -IPV(N-SIZE_SCHUR+1) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = -IPV(N-SIZE_SCHUR+1) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0 NV(ME) = SIZE_SCHUR RETURN END SUBROUTINE SMUMPS_199 SUBROUTINE SMUMPS_198(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, IOVFLO, MP) INTEGER N,NZ,LW,IWFR,IFLAG,IERROR INTEGER PERM(N) INTEGER IQ(N) INTEGER IRN(NZ), ICN(NZ) INTEGER IPE(N), IW(LW), FLAG(N) INTEGER MP INTEGER IOVFLO INTEGER I,J,K,LBIG,L,ID,IN,LEN,JDUMMY,K1,K2 IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1,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 LBIG = 0 DO 100 I=1,N L = IQ(I) LBIG = max0(L,LBIG) IWFR = IWFR + L IPE(I) = IWFR - 1 100 CONTINUE DO 140 K=1,NZ I = -IW(K) IF (I.LE.0) GO TO 140 L = K IW(K) = 0 DO 130 ID=1,NZ J = ICN(L) IF (PERM(I).LT.PERM(J)) GO TO 110 L = IPE(J) IPE(J) = L - 1 IN = IW(L) IW(L) = I GO TO 120 110 L = IPE(I) IPE(I) = L - 1 IN = IW(L) IW(L) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1 L = K + N IWFR = L + 1 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(L) = IW(K) K = K - 1 L = L - 1 150 CONTINUE 160 IPE(J) = L L = L - 1 170 CONTINUE IF (LBIG.GE.IOVFLO) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0 180 CONTINUE GO TO 230 190 IWFR = 1 DO 220 I=1,N K1 = IPE(I) + 1 K2 = IPE(I) + IQ(I) IF (K1.LE.K2) GO TO 200 IPE(I) = 0 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = IWFR - K - 1 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM SMUMPS_198 ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE SMUMPS_198 SUBROUTINE SMUMPS_194(N, IPE, IW, LW, IWFR,NCMPA) INTEGER N,LW,IWFR,NCMPA INTEGER IPE(N) INTEGER IW(LW) INTEGER I,K1,LWFR,IR,K,K2 NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0) GO TO 10 IPE(I) = IW(K1) IW(K1) = -I 10 CONTINUE IWFR = 1 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) = IPE(I) IPE(I) = IWFR K1 = K + 1 K2 = K + IW(IWFR) IWFR = IWFR + 1 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1 40 CONTINUE 50 LWFR = K2 + 1 60 CONTINUE 70 RETURN END SUBROUTINE SMUMPS_194 #if defined(OLDDFS) SUBROUTINE SMUMPS_200(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_200 #else SUBROUTINE SMUMPS_557(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 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 #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 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 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 #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(20000)* & dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) & ) & / & ( dble(NV(DADI)+NODE(I))* & dble(NV(DADI)+NODE(I)) ) ACCU = ACCU + dble(CUMUL(I) ) AMALG_TO_father_OK = ( (NODE(I).LE.NEMIN).OR. & (NODE(DADI).LE.NEMIN) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( & ( dble(2*(NODE(I)))* & dble((NV(DADI)-NV(I)+NODE(I))) & ) .LT. & ( dble(NV(DADI)+NODE(I))* & dble(NV(DADI)+NODE(I))*dble(NEMIN)/dble(100) & ) & ) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU .LE. dble(NEMIN)*dble(100) ) & ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_511(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_511(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_511(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF(FLOPS_APRES .GT. FLOPS_AVANT) 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 AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) 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_557 #endif SUBROUTINE SMUMPS_201(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 IF(NFR .NE. NELIM) 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_201 SUBROUTINE SMUMPS_348( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(INOUT) :: 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_348 SUBROUTINE SMUMPS_203( N, NZ, MTRANS, PERM, & id, ICNTL, INFO) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER N, NZ, LIWG INTEGER PERM(N) INTEGER MTRANS INTEGER ICNTL(40), INFO(40) INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW REAL, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER LS2,LSC INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) REAL CNTL64(10) INTEGER LDW, LDWMIN INTEGER MPRINT,LP, MP, IPIW, LIW, LIWMIN INTEGER JPERM INTEGER NUMNZ, I, J, JPOS, K, NZREAL INTEGER PLENR, IP, IRNW,RSPOS,CSPOS LOGICAL PROK, IDENT, DUPPLI INTEGER NZTOT, K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG 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) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = (MPRINT.GT.0) 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 .EQ. 2) THEN NZTOT = 2*NZ+N ELSE NZTOT = NZ ENDIF ZERODIAG => id%IS1(N+1:2*N) STR_KER => id%IS1(2*N+1:3*N) CALL SMUMPS_448(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 DIAGIONAL' 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 IP = IRNW + NZTOT PLENR = IP + N + 1 IPIW = PLENR IF (MTRANSLOC.EQ.1) LIWMIN = 5*N IF (MTRANSLOC.EQ.2) LIWMIN = 4*N IF (MTRANSLOC.EQ.3) LIWMIN = 10*N + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 5*N IF (MTRANSLOC.EQ.5) LIWMIN = 5*N IF (MTRANSLOC.EQ.6) LIWMIN = 5*N + NZTOT LIW = LIWMIN LIWG = LIW + (NZTOT + N + 1) ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) GOTO 410 IF (MTRANSLOC.EQ.1) THEN LDWMIN = N+3 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max(N+NZTOT,N+3) IF (MTRANSLOC.EQ.3) LDWMIN = max(NZTOT+1,N+3) IF (MTRANSLOC.EQ.4) LDWMIN = 2*N + max(NZTOT,N+3) IF (MTRANSLOC.EQ.5) LDWMIN = 3*N + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4*N + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N IF (allocok .GT. 0 ) GOTO 430 NZREAL = 0 DO 5 J=1,N IW(PLENR+J-1) = 0 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 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 NZREAL = NZREAL + 1 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 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 NZREAL = NZREAL + 1 IF(I .NE. J) THEN IW(PLENR+I-1) = IW(PLENR+I-1) + 1 NZREAL = NZREAL + 1 ELSE IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = K 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 IW(PLENR+I-1) = IW(PLENR+I-1) + 1 NZREAL = NZREAL + 1 ENDIF ENDDO ENDIF ENDIF IW(IP) = 1 DO 20 J=1,N IW(IP+J) = IW(IP+J-1)+IW(PLENR+J-1) 20 CONTINUE DO 25 J=1, N IW(PLENR+J-1 ) = IW(IP+J-1 ) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO 30 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I IW(PLENR+J-1) = IW(PLENR+J-1) + 1 ENDIF 30 CONTINUE ELSE IF ( .not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO 35 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I S2(JPOS) = abs(id%A(K)) IW(PLENR+J-1) = IW(PLENR+J-1) + 1 ENDIF 35 CONTINUE 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I IW(PLENR+J-1) = IW(PLENR+J-1) + 1 IF(I.NE.J) THEN JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = J IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF K = 1 THEMIN = ZERO DO IF(THEMIN .NE. ZERO) EXIT THEMIN = abs(id%A(K)) K = K+1 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I S2(JPOS) = abs(id%A(K)) IW(PLENR+J-1) = IW(PLENR+J-1) + 1 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 JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = J S2(JPOS) = abs(id%A(K)) IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = I S2(JPOS) = ZERO IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDDO CNTL64(2) = (log(THEMAX/THEMIN))*(real(N)) & - log(THEMIN) + ONE ENDIF ENDIF DUPPLI = .FALSE. I = NZREAL FLAG => id%IS1(3*N+1:4*N) IF(MTRANSLOC.NE.1) THEN CALL SMUMPS_563(N,NZREAL,IW(IP),IW(IRNW),S2, & PERM,FLAG(1)) ELSE CALL SMUMPS_562(N,NZREAL,IW(IP),IW(IRNW), & PERM,FLAG(1)) ENDIF IF(NZREAL .NE. I) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1 LDW = 1 ENDIF CALL SMUMPS_559(MTRANSLOC ,N, N, NZREAL, & IW(IP), IW(IRNW), S2(1), LS2, & NUMNZ, PERM, LIW, IW(IPIW), LDW, S2(LS2+1), & ICNTL64, CNTL64, INFO64) 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(PLENR+JPERM-1) = 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(PLENR+J-1) 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_203' 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_203' 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 id%ROWSCA(J) = exp(S2(RSPOS+J)) 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+J)) IF(id%COLSCA(J) .EQ. ZERO) THEN id%COLSCA(J) = ONE ENDIF ELSE id%COLSCA(IW(PLENR+J-1))= exp(S2(CSPOS+J)) IF(id%COLSCA(IW(PLENR+J-1)) .EQ. ZERO) THEN id%COLSCA(IW(PLENR+J-1)) = 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_203' 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_203' 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)+S2(CSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO S2(CSPOS+J)= ZERO ENDIF ENDDO DO J=1,N IF(PERM(J) .GT. 0) THEN id%ROWSCA(J) = & exp((S2(RSPOS+J)+S2(CSPOS+J))/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 J = IW(IP+I-1),IW(IP+I) - 1 IF ( PERM( IW( IRNW+J-1) ) > 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_551( & N, NZREAL, IW(IP), 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_203' 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_203' WRITE (LP,'(A,I9)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -5 INFO(2) = LIWG GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_203' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 INFO(2) = LDW 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) RETURN END SUBROUTINE SMUMPS_203 SUBROUTINE SMUMPS_100 &( 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) 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_100 SUBROUTINE SMUMPS_97 & ( 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) MAX_DEPTH=1 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) 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_313 & ( 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_97 RECURSIVE SUBROUTINE SMUMPS_313 & ( 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_50, & MUMPS_52 EXTERNAL MUMPS_50, & MUMPS_52 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_50 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB) NSLAVESMAX = MUMPS_52 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB) 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 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 ) CALL SMUMPS_313 & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG ) IF (.NOT. SPLITROOT) THEN CALL SMUMPS_313 & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG ) ENDIF RETURN END SUBROUTINE SMUMPS_313 SUBROUTINE SMUMPS_351 & (N,NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, MedDens, NBQD, AvgDens) INTEGER N,NZ,LW,IFLAG,IERROR,NRORM,NIORM,IWFR INTEGER symmetry, SYM INTEGER MedDens, NBQD, AvgDens INTEGER ICNTL(40) INTEGER IRN(NZ), ICN(NZ) INTEGER LEN(N) INTEGER IPE(N+1) INTEGER FLAG(N), IW(LW) INTEGER IQ(N) INTEGER MP, MPG INTEGER I,K,J,N1,LAST,NDUP,K1,K2,L INTEGER NBERR, THRESH INTEGER NZOFFA, NDIAGA REAL RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NIORM = 3*N NDIAGA = 0 IERROR = 0 DO 10 I=1,N IPE(I) = 0 10 CONTINUE DO 50 K=1,NZ I = IRN(K) J = ICN(K) 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 IPE(J) = IPE(J) + 1 NIORM = NIORM + 1 ELSE NDIAGA = NDIAGA + 1 ENDIF ENDIF 50 CONTINUE NZOFFA = NIORM - 3*N 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 K=1,NZ I = IRN(K) J = ICN(K) 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(K,10).GT.3 .OR. mod(K,10).EQ.0 .OR. & (10.LE.K .AND. K.LE.20)) THEN WRITE (MP,'(I8,A,I8,A,I8,A)') & K,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K,10).EQ.1) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'st entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.2) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.3) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2*N IQ(1) = 1 N1 = N - 1 IF (N1.GT.0) THEN DO 110 I=1,N1 IQ(I+1) = IPE(I) + IQ(I) 110 CONTINUE 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 DO 200 K=1,NZ I = IRN(K) J = ICN(K) 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 200 CONTINUE NDUP = 0 DO 260 I=1,N K1 = IPE(I) K2 = IQ(I) -1 IF (K1.GT.K2) THEN LEN(I) = 0 IQ(I) = 0 ELSE DO 240 K=K1,K2 J = -IW(K) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1 IW(L) = 0 IW(K) = 0 ELSE IW(L) = I IW(K) = J FLAG(J) = I ENDIF 240 CONTINUE 250 IQ(I) = IQ(I) - IPE(I) IF (NDUP.EQ.0) LEN(I) = IQ(I) ENDIF 260 CONTINUE IF (NDUP.NE.0) THEN IWFR = 1 DO 280 I=1,N IF (IQ(I).EQ.0) THEN LEN(I) = 0 IPE(I) = IWFR GOTO 280 ENDIF K1 = IPE(I) K2 = K1 + IQ(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K=K1,K2 IF (IW(K).NE.0) THEN IW(IWFR) = IW(K) IWFR = IWFR + 1 ENDIF 270 CONTINUE LEN(I) = IWFR - L 280 CONTINUE ENDIF IPE(N+1) = IPE(N) + LEN(N) IWFR = IPE(N+1) IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2*NZOFFA - (IWFR-1))/ & real(NZOFFA+NDIAGA) symmetry = nint (100.0E0*RSYM) IF (MPG .GT. 0) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ELSE symmetry = 100 ENDIF AvgDens = nint(real(IWFR-1)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN IQ(1:N) = 0 DO I= 1, N K = max(LEN(I),1) IQ(K) = IQ(K) + 1 IF (K.GT.THRESH) NBQD = NBQD+1 ENDDO K = 0 MedDens = 0 DO WHILE (K .LT. (N/2)) MedDens = MedDens + 1 K = K+IQ(MedDens) ENDDO ELSE MedDens = AvgDens ENDIF IF (MPG .GT. 0) & write(MPG,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE SMUMPS_351 SUBROUTINE SMUMPS_701(N, SYM, NPROCS, IORD, & symmetry,MedDens, NBQD, AvgDens, & PROK, MP) IMPLICIT NONE INTEGER, intent(in) :: N, NPROCS, SYM INTEGER, intent(in) :: symmetry,MedDens, 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) 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 (NBQD.GE.MedDens*NPROCS) THEN IORD = 6 RETURN ENDIF #if defined(metis) || defined(parmetis) 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 (NBQD.GE.MedDens*NPROCS) THEN IORD = 6 RETURN ENDIF #if defined(metis) || defined(parmetis) 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 SMUMPS_701 SUBROUTINE SMUMPS_510 & (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_510 SUBROUTINE SMUMPS_559(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & ICNTL,CNTL,INFO) IMPLICIT NONE INTEGER NICNTL, NCNTL, NINFO PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER JOB,M,N,NE,NUM,LIW,LDW INTEGER IP(N+1),IRN(NE),PERM(M),IW(LIW) INTEGER ICNTL(NICNTL),INFO(NINFO) INTEGER LA REAL A(LA) REAL DW(LDW),CNTL(NCNTL) INTEGER I,J,K,WARN1,WARN2,WARN4 REAL FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0E+00,ONE=1.0E+0) EXTERNAL SMUMPS_457,SMUMPS_444,SMUMPS_451, & SMUMPS_452,SMUMPS_454 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 INFO(2) = NE IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = 4*N + M IF (JOB.EQ.2) K = 2*N + 2*M IF (JOB.EQ.3) K = 8*N + 2*M + NE IF (JOB.EQ.4) K = 3*N + 2*M IF (JOB.EQ.5) K = 3*N + 2*M IF (JOB.EQ.6) K = 3*N + 2*M + NE IF (LIW.LT.K) THEN INFO(1) = -4 INFO(2) = K 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 = M IF (JOB.EQ.3) K = 1 IF (JOB.EQ.4) K = 2*M IF (JOB.EQ.5) K = N + 2*M IF (JOB.EQ.6) K = N + 3*M IF (LDW.LT.K) THEN INFO(1) = -5 INFO(2) = K 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 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(J),J=1,min(10,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,min(10,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(J),J=1,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,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) = IP(J+1) - IP(J) 10 CONTINUE CALL SMUMPS_457(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_444(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(2*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_451(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL SMUMPS_452(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) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1 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 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IW(1) = JOB CALL SMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) 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 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 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 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 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_451(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 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 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IW(1) = JOB IF (JOB.EQ.5) THEN CALL SMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL SMUMPS_454(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) 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 (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_443. INFO(1) = ',I2, & ' because ',(A),' = ',I10) 9004 FORMAT (' ****** Error in SMUMPS_443. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I8) 9005 FORMAT (' ****** Error in SMUMPS_443. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I8) 9006 FORMAT (' ****** Error in SMUMPS_443. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in SMUMPS_443. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from SMUMPS_443. 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_443:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I10) 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_443:'/ & ' 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_559 SUBROUTINE SMUMPS_563(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER N,NZ INTEGER IP(N+1),IRN(NZ) REAL A(NZ) INTEGER WR_POS,BEG_COL,ROW,COL,K,SV_POS INTEGER FLAG(N), POSI(N) FLAG = 0 WR_POS = 1 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1 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 RETURN END SUBROUTINE SMUMPS_563 SUBROUTINE SMUMPS_562(N,NZ,IP,IRN,FLAG,POSI) IMPLICIT NONE INTEGER N,NZ INTEGER IP(N+1),IRN(NZ) INTEGER WR_POS,BEG_COL,ROW,COL,K INTEGER FLAG(N), POSI(N) FLAG = 0 WR_POS = 1 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1 RETURN END SUBROUTINE SMUMPS_562 SUBROUTINE SMUMPS_181( 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_181 SUBROUTINE SMUMPS_746( ID, PTRAR ) USE SMUMPS_STRUC_DEF IMPLICIT NONE include 'mpif.h' TYPE(SMUMPS_STRUC), INTENT(IN), TARGET :: ID INTEGER, TARGET :: PTRAR(ID%N,2) INTEGER :: IERR INTEGER :: IOLD, K, JOLD, INEW, JNEW, INZ INTEGER, POINTER :: IIRN(:), IJCN(:), IWORK1(:), IWORK2(:) LOGICAL :: IDO, PARANAL PARANAL = .TRUE. IF (PARANAL) THEN IF(ID%KEEP(54) .EQ. 3) THEN IIRN => ID%IRN_loc IJCN => ID%JCN_loc INZ = ID%NZ_loc IWORK1 => PTRAR(1:ID%N,2) allocate(IWORK2(ID%N)) IDO = .TRUE. ELSE IIRN => ID%IRN IJCN => ID%JCN INZ = ID%NZ IWORK1 => PTRAR(1:ID%N,1) IWORK2 => PTRAR(1:ID%N,2) IDO = ID%MYID .EQ. 0 END IF ELSE IIRN => ID%IRN IJCN => ID%JCN INZ = ID%NZ 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 IWORK2(IOLD) = 0 50 CONTINUE IF(IDO) THEN DO 70 K=1,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 ELSE IWORK1(JOLD) = IWORK1(JOLD) + 1 ENDIF ELSE IF ( INEW .LT. JNEW ) THEN IWORK1( IOLD ) = IWORK1( IOLD ) + 1 ELSE IWORK1( JOLD ) = IWORK1( JOLD ) + 1 END IF ENDIF ENDIF 70 CONTINUE END IF IF(PARANAL .AND. (ID%KEEP(54) .EQ. 3) ) THEN CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1,1), ID%N, MPI_INTEGER, & MPI_SUM, ID%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), ID%N, MPI_INTEGER, & MPI_SUM, ID%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR, 2*ID%N, MPI_INTEGER, & 0, ID%COMM, IERR ) END IF RETURN END SUBROUTINE SMUMPS_746 MODULE SMUMPS_PARALLEL_ANALYSIS USE SMUMPS_STRUC_DEF USE TOOLS_COMMON INCLUDE 'mpif.h' PUBLIC SMUMPS_715 INTERFACE SMUMPS_715 MODULE PROCEDURE SMUMPS_715 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 :: NZ_LOC, 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 :: MEMCNT, MAXMEM, MP, MPG, LP, NRL, TOPROWS LOGICAL :: PROK, PROKG CONTAINS SUBROUTINE SMUMPS_715(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) 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%NZ_loc = id%NZ ELSE id%NZ_loc = 0 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) MEMCNT = size(work1)+ size(work2) + & size(nfsiz) + size(fils) + size(frere) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT entry:',MEMCNT,MAXMEM #endif CALL SMUMPS_716(id, ord) id%INFOG(7) = id%KEEP(245) CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL SMUMPS_717(id, ord, WORK2) CALL MUMPS_276( 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_733(IPE, id%N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NV, id%N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT ipe nv:',MEMCNT,MAXMEM #endif END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 CALL SMUMPS_720(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_276( 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_734(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT firstlast:',MEMCNT,MAXMEM #endif 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_733(CUMUL, id%N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT cumul:',MEMCNT,MAXMEM #endif NEMIN = id%KEEP(1) CALL SMUMPS_557(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_734(CUMUL, NV, IPE, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall cumul:',MEMCNT,MAXMEM #endif CALL SMUMPS_201(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_209(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_510(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 IF ( huge(id%KEEP8(79)) / K79REF + 1_8 .GE. & int(id%NSLAVES,8) ) THEN id%KEEP8(79)=huge(id%KEEP8(79)) ELSE id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF 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_97(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_97(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 #if defined (memprof) write(mp,'(i2,a30,3(i8,5x))')myid,'MEMCNT exit:',MEMCNT,MAXMEM, & estimem(myid, id%n, 2*id%nz/id%n) #endif RETURN END SUBROUTINE SMUMPS_715 SUBROUTINE SMUMPS_716(id, ord) TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: IERR #if defined(parmetis) 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) IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to PT-SCOTCH.")') RETURN #endif #if defined(parmetis) I=1 DO IF (I .GT. id%NSLAVES) 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.")') 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) I=1 DO IF (I .GT. id%NSLAVES) 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_716 SUBROUTINE SMUMPS_717(id, ord, WORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) #ifdef parmetis INTEGER :: IERR #endif IF (ord%ORDTOOL .EQ. 1) THEN #ifdef ptscotch CALL SMUMPS_719(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 #ifdef parmetis CALL SMUMPS_718(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_717 #if defined(parmetis) SUBROUTINE SMUMPS_718(id, ord, WORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR, BASE INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & EDGELOCNBR, OPTIONS(10), NROWS_LOC INTEGER, POINTER :: VERTLOCTAB(:), & EDGELOCTAB(:), RCVCNTS(:) 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) IF(MUMPS_795(WORK) .LT. ID%N*3) THEN WRITE(LP, & '("Insufficient workspace inside SMUMPS_718")') CALL MUMPS_ABORT() END IF CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, LP, & STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, LP, & STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT perm peri:', & MEMCNT,MAXMEM #endif BASEVAL = 1 BASE = id%NPROCS-id%NSLAVES VERTLOCTAB => ord%PERMTAB CALL MUMPS_733(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, & MAXMEM #endif DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO DO I=BASE, BASE+ord%NSLAVES-2 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) END DO FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* & (BASE+ord%NSLAVES-1-BASE)+1 LAST(BASE+ord%NSLAVES) = id%N DO I=BASE+ord%NSLAVES, NPROCS FIRST(I+1) = id%N+1 LAST(I+1) = id%N END DO VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 SWORK => WORK(id%N+1:3*id%N) CALL SMUMPS_776(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 OPTIONS(:) = 0 NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 ORDER => WORK(1:id%N) CALL MUMPS_733(SIZES, 2*ord%NSLAVES, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT sizes:',MEMCNT,MAXMEM #endif IF(ord%IDO) THEN CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB, & EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES) END IF CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM #endif NULLIFY(VERTLOCTAB) CALL MPI_BCAST(SIZES, 2*ord%NSLAVES, MPI_INTEGER, & BASE, id%COMM, IERR) ord%CBLKNBR = 2*ord%NSLAVES-1 CALL MUMPS_733(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rcvcnts:',MEMCNT,MAXMEM #endif 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, NROWS_LOC, MPI_INTEGER, ord%PERMTAB, & RCVCNTS, FIRST, MPI_INTEGER, id%COMM, IERR ) DO I=1, id%N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_733(ord%RANGTAB, 2*ord%NSLAVES, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rangtab:',MEMCNT,MAXMEM #endif CALL MUMPS_733(ord%TREETAB, ord%CBLKNBR, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_778(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_734(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sizes:',MEMCNT,MAXMEM #endif CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM #endif CALL SMUMPS_777(ord) ord%N = id%N ord%COMM = id%COMM RETURN END SUBROUTINE SMUMPS_718 #endif #if defined(ptscotch) SUBROUTINE SMUMPS_719(id, ord, WORK) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & EDGELOCNBR, MYWORKID, & BASE INTEGER, POINTER :: VERTLOCTAB(:), & EDGELOCTAB(:) DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) IF(MUMPS_795(WORK) .LT. ID%N*3) THEN WRITE(LP, & '("Insufficient workspace inside SMUMPS_719")') CALL MUMPS_ABORT() END IF IF(ord%SUBSTRAT .EQ. 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=n{sep=/(vert>120)?'// & '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=f{cmin=15,cmax=100000,frat=0.0},ose=g}}' ELSE 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 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_733(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, & MAXMEM #endif DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO DO I=BASE, BASE+ord%NSLAVES-2 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) END DO FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* & (BASE+ord%NSLAVES-1-BASE)+1 LAST(BASE+ord%NSLAVES) = id%N DO I=BASE+ord%NSLAVES, NPROCS-1 FIRST(I+1) = id%N+1 LAST(I+1) = id%N END DO VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 VERTLOCTAB => WORK(1:id%N) SWORK => WORK(id%N+1:3*id%N) CALL SMUMPS_776(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%RANGTAB, id%N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%TREETAB, id%N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT permtab:',MEMCNT,MAXMEM #endif IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF IF(ord%IDO) THEN CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in dgraph init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), VERTLOCTAB(1), & VERTLOCTAB(1), EDGELOCNBR, EDGELOCNBR, EDGELOCTAB(1), & EDGELOCTAB(1), EDGELOCTAB(1), IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in dgraph build")') CALL MUMPS_ABORT() END IF CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in strat init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in strat build")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order compute")') CALL MUMPS_ABORT() END IF IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB, ord%PERITAB, ord%CBLKNBR, ord%RANGTAB, & ord%TREETAB, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in Corder init")') CALL MUMPS_ABORT() END IF END IF IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order gather")') CALL MUMPS_ABORT() END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order gather")') CALL MUMPS_ABORT() END IF END IF END IF IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERITAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB, id%N+1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%TREETAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_777(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM #endif ord%N = id%N ord%COMM = id%COMM CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM #endif RETURN END SUBROUTINE SMUMPS_719 #endif FUNCTION SMUMPS_793(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: SMUMPS_793 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 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF SMUMPS_793 = .FALSE. IF(NACTIVE .GE. RPROC) THEN SMUMPS_793 = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN SMUMPS_793 = .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 NZ_ROW = 2*(id%NZ/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_793 = .TRUE. RETURN ELSE SMUMPS_793 = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION SMUMPS_793 FUNCTION SMUMPS_779(NODE, ord) IMPLICIT NONE INTEGER :: SMUMPS_779 INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR SMUMPS_779 = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE SMUMPS_779 = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN SMUMPS_779 = SMUMPS_779+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION SMUMPS_779 SUBROUTINE SMUMPS_781(ord, id) USE TOOLS_COMMON 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 ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1)) ALIST(1) = ord%CBLKNBR AWEIGHTS(1) = ord%NW(ord%CBLKNBR) NACTIVE = 1 RPROC = NNODES ANODE = 0 PEAKMEM = 0 CALL MUMPS_733(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%FIRST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%LAST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')ord%myid,'MEMCNT topnodes:',MEMCNT, & MAXMEM #endif ord%TOPNODES = 0 IF((ord%CBLKNBR .EQ. 1) .OR. & ( RPROC .LT. SMUMPS_779(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 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = SMUMPS_779(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_793(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_783(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL SMUMPS_784(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_783(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL SMUMPS_784(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_781 SUBROUTINE SMUMPS_720(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, POINTER :: PE(:), IPE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & RCVCNT(:), LSTVAR(:) INTEGER, POINTER :: NROOTS(:), MYLIST(:), & MYNVAR(:), LVARPT(:), & DISPLS(:), LPERM(:), & LIPERM(:), & IPET(:), NVT(:), BUF_PE1(:), & BUF_PE2(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP1(:), TMP2(:), BWORK(:) INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, MYNROOTS, PNT, TMP, & NCLIQUES, NTVAR, PFREES, PFREET, TGSIZE, MAXS, RHANDPE, & RHANDNV, STATUSPE(MPI_STATUS_SIZE), & STATUSNV(MPI_STATUS_SIZE), RIDX, PROC, NBBUCK, & PFS_SAVE, PFT_SAVE LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, RCVCNT, LSTVAR) nullify(NROOTS, MYLIST, MYNVAR, LVARPT, DISPLS, & 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_795(WORK) .LT. 4*id%N) THEN WRITE(LP,*)'Insufficient workspace in SMUMPS_720' 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_781(ord, id) CALL MUMPS_734(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))') myid,'deall son:',MEMCNT,MAXMEM #endif 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_775(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK) 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_733(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT allsub:',MEMCNT,MAXMEM #endif 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 IF (ord%SUBSTRAT .EQ. 0) THEN DO I=1, HIDX PERM(I) = I END DO CALL MUMPS_420(1, THRESH, NDENSE(1), HIDX, & MUMPS_795(PE), 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) ELSE NBBUCK = 2*TMP CALL MUMPS_419 (ord%SUBSTRAT, 1, .FALSE., HIDX, NBBUCK, & MUMPS_795(PE), IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), PERM(1), NEXT(1), & W(1), HEAD(1), AGG6, SIZE_SCHUR, LISTVAR_SCHUR(1) ) DO I=1, HIDX PERM(I) = I END DO END IF CALL MUMPS_733(W, 2*NPROCS, id%INFO, & LP, STRING='W', MEMCNT=MEMCNT, ERRCODE=-7) if(MEMCNT .gt. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT w:',MEMCNT,MAXMEM #endif NROOTS => W DISPLS => W(NPROCS+1:2*NPROCS) MYNVAR => DEGREE MYLIST => NDENSE LVARPT => NEXT RCVCNT => HEAD LSTVAR => LAST NULLIFY(W, DEGREE, NDENSE, NEXT, HEAD, LAST) MYNROOTS = 0 PNT = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN PNT = PNT+LENG(I) MYNROOTS = MYNROOTS+1 END IF END DO CALL MUMPS_733(MYLIST, PNT, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT mylist:',MEMCNT,MAXMEM #endif MYNROOTS = 0 PNT = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYNROOTS = MYNROOTS+1 MYNVAR(MYNROOTS) = LENG(I) DO J=1, LENG(I) MYLIST(PNT+J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO PNT = PNT+LENG(I) END IF END DO CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_GATHER(MYNROOTS, 1, MPI_INTEGER, NROOTS(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) IF(MYID .EQ.0) THEN DISPLS(1) = 0 DO I=2, NPROCS DISPLS(I) = DISPLS(I-1)+NROOTS(I-1) END DO NCLIQUES = sum(NROOTS(1:NPROCS)) CALL MUMPS_733(LVARPT, NCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ELSE CALL MUMPS_733(LVARPT, 2, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT lvarpt:',MEMCNT,MAXMEM #endif CALL MPI_GATHERV(MYNVAR(1), MYNROOTS, MPI_INTEGER, LVARPT(2), & NROOTS(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) IF(MYID .EQ. 0) THEN DO I=1, NPROCS RCVCNT(I) = sum(LVARPT(2+DISPLS(I):2+DISPLS(I)+NROOTS(I)-1)) IF(I .EQ. 1) THEN DISPLS(I) = 0 ELSE DISPLS(I) = DISPLS(I-1)+RCVCNT(I-1) END IF END DO CALL MUMPS_733(LSTVAR, sum(RCVCNT(1:NPROCS)), id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT lstvar:',MEMCNT,MAXMEM #endif END IF CALL MPI_GATHERV(MYLIST(1), PNT, MPI_INTEGER, LSTVAR(1), & RCVCNT(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) NULLIFY(DISPLS) IF(MYID .EQ. 0) THEN LVARPT(1) = 1 DO I=2, NCLIQUES+1 LVARPT(I) = LVARPT(I-1) + LVARPT(I) END DO LPERM => WORK(3*id%N+1 : 4*id%N) NTVAR = ord%TOPNODES(2) CALL SMUMPS_782(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL SMUMPS_774(id, ord%TOPNODES(2), LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPET, PE, LENG, ELEN) TGSIZE = ord%TOPNODES(2)+NCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) CALL MUMPS_734(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) W => NROOTS DEGREE => MYNVAR NDENSE => MYLIST NEXT => LVARPT HEAD => RCVCNT LAST => LSTVAR NULLIFY(NROOTS, MYNVAR, MYLIST, LVARPT, RCVCNT, LSTVAR) CALL MUMPS_733(PE, max(PFREET+TGSIZE,1), id%INFO, LP, & COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LISTVAR_SCHUR, max(NCLIQUES,1), id%INFO, LP, & STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT pe:',MEMCNT,MAXMEM #endif DO I=1, NCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 IF(ord%TOPSTRAT .EQ. 0) THEN CALL MUMPS_733(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rehead:',MEMCNT,MAXMEM #endif DO I=1, TGSIZE PERM(I) = I END DO CALL MUMPS_420(2, -1, NDENSE(1), TGSIZE, & MUMPS_795(PE), 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), NCLIQUES, & AGG6) ELSE NBBUCK = 2*TGSIZE CALL MUMPS_733(HEAD, NBBUCK+2, id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(PERM, TGSIZE, id%INFO, & LP, STRING='J2:PERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rehead:',MEMCNT,MAXMEM #endif CALL MUMPS_419 (ord%TOPSTRAT, 2, .FALSE., TGSIZE, & NBBUCK, MUMPS_795(PE), IPET(1), PFREET, LENG(1), & PE(1), NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), & PERM(1), NEXT(1), W(1), HEAD(1), AGG6, NCLIQUES, & LISTVAR_SCHUR(1) ) END IF END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MUMPS_734(LISTVAR_SCHUR, PE, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall lvs:',MEMCNT,MAXMEM #endif IF(MYID .EQ. 0) THEN BUF_PE1 => WORK( 1 : id%N) BUF_PE2 => WORK( id%N+1 : 2*id%N) BUF_NV1 => WORK(2*id%N+1 : 3*id%N) BUF_NV2 => WORK(3*id%N+1 : 4*id%N) 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_733(BUF_PE1, MAXS, id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_PE2, MAXS, id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_NV1, MAXS, id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_NV2, MAXS, id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(GPE, id%N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(GNV, id%N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ROOTPERM, NCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT buf_pe1:',MEMCNT, & MAXMEM #endif 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_INTEGER, 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, NCLIQUES 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_INTEGER, 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_734(PE, IPE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_734(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_734(LSTVAR, NROOTS, MYLIST, MYNVAR, & LVARPT, MEMCNT=MEMCNT) CALL MUMPS_734(LPERM, LIPERM, IPET, NVT, & MEMCNT=MEMCNT) CALL MUMPS_734(ROOTPERM, TMP1, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, RCVCNT) RETURN END SUBROUTINE SMUMPS_720 SUBROUTINE SMUMPS_782(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_733(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT lperm:',MEMCNT, & MAXMEM #endif 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_782 SUBROUTINE SMUMPS_774(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(:), LVARPT(:), & IPE(:), PE(:), LENG(:), ELEN(:) INTEGER :: NCLIQUES INTEGER :: I, J, IDX, NLOCVARS, PNT, SAVEPNT CALL MUMPS_733(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT leng:',MEMCNT, & MAXMEM #endif LENG = 0 ELEN = 0 DO I=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN LENG(LPERM(top_graph%IRN_LOC(I))) = & LENG(LPERM(top_graph%IRN_LOC(I))) + 1 END IF END DO DO I=1, NCLIQUES DO J=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+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)+LENG(I)+ELEN(I) END DO CALL MUMPS_733(PE, IPE(NLOCVARS+NCLIQUES+1)+NLOCVARS+NCLIQUES, & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT repe:',MEMCNT, & MAXMEM #endif LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO J=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(J)) PE(IPE(IDX)+ELEN(IDX)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+LENG(NLOCVARS+I)) = IDX ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO I=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN PE(IPE(LPERM(top_graph%IRN_LOC(I)))+ & ELEN(LPERM(top_graph%IRN_LOC(I))) + & LENG(LPERM(top_graph%IRN_LOC(I)))) = & LPERM(top_graph%JCN_LOC(I)) LENG(LPERM(top_graph%IRN_LOC(I))) = & LENG(LPERM(top_graph%IRN_LOC(I))) + 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 J=IPE(I), IPE(I+1)-1 IF(LPERM(PE(J)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE SMUMPS_774 SUBROUTINE SMUMPS_778(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:2) = (/1, 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_778 SUBROUTINE SMUMPS_776(id, FIRST, LAST, IPE, & PE, WORK) IMPLICIT NONE INCLUDE 'mpif.h' TYPE(SMUMPS_STRUC) :: id INTEGER, POINTER :: FIRST(:), LAST(:), IPE(:), PE(:), & WORK(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, LOCNNZ, & NEW_LOCNNZ, J, LOC_ROW INTEGER :: TOP_CNT, TIDX, & NROWS_LOC, DUPS, TOTDUPS, OFFDIAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), & SNDCNT(:), RCVCNT(:), SDISPL(:) INTEGER, POINTER :: RDISPL(:), & MSGCNT(:), SIPES(:,:), LENG(:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, & SAVEPNT INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL) nullify(RDISPL, MSGCNT, SIPES, LENG) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_795(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_733(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT sndcnt:',MEMCNT,MAXMEM #endif ALLOCATE(APNT(NPROCS)) SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 1000 LOCNNZ = id%NZ_loc 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 I=1, id%NZ_loc IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(I)) LOC_ROW = id%IRN_loc(I)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(I)) LOC_ROW = id%JCN_loc(I)-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%KEEP(114), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) id%KEEP(114) = id%KEEP(114)+3*id%N id%KEEP(113) = id%KEEP(114)-2*id%N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, id%COMM, IERR) SNDCNT(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) CALL MUMPS_733(IPE, NROWS_LOC+1, id%INFO, & LP, STRING='IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT ripe:',MEMCNT,MAXMEM #endif IPE(1) = 1 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + LENG(I) END DO CALL MUMPS_733(PE, max(IPE(NROWS_LOC+1)-1,1), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe:',MEMCNT,MAXMEM #endif LENG(:) = 0 CALL SMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) NEW_LOCNNZ = sum(RCVCNT) DO I=1, NPROCS MSGCNT(I) = RCVCNT(I)/BUFSIZE END DO RCVPNT = 1 SNDCNT = 0 TIDX = 0 DO I=1, id%NZ_loc IF(mod(I,BUFSIZE/10) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, MPI_COMM_WORLD, STATUS, IERR) CALL SMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%IRN_loc(I)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%JCN_loc(I) SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF PROC = MAPTAB(id%JCN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%JCN_loc(I)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%IRN_loc(I) SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF END DO CALL SMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO J=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(J)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER, MPI_SUM, & 0, id%COMM, IERR ) SYMMETRY = dble(TOTDUPS)/(dble(id%NZ)-dble(id%N)) IF(MYID .EQ. 0) THEN IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'("Structual symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_734(SNDCNT, RCVCNT, MSGCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM #endif RETURN END SUBROUTINE SMUMPS_776 SUBROUTINE SMUMPS_775(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK) IMPLICIT NONE INCLUDE 'mpif.h' TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: IPE(:), PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, LOCNNZ, & NEW_LOCNNZ, J, LOC_ROW INTEGER :: TOP_CNT,IIDX,JJDX INTEGER :: HALO_SIZE, TIDX, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), & SNDCNT(:), RCVCNT(:), & SDISPL(:), HALO_MAP(:) INTEGER, POINTER :: RDISPL(:), & MSGCNT(:), SIPES(:,:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, & SAVEPNT INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_795(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_733(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rrsndcnt:',MEMCNT,MAXMEM #endif ALLOCATE(APNT(NPROCS)) SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 LOCNNZ = id%NZ_loc 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 I=1, id%NZ_loc IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(I)) 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(I)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(I)) 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_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, id%COMM, IERR) I = ceiling(real(MAXS)*1.20E0) CALL MUMPS_733(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrleng2:',MEMCNT, & MAXMEM #endif SNDCNT(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(real(NROWS_LOC+1)*1.20E0) CALL MUMPS_733(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rripe:',MEMCNT,MAXMEM #endif IPE(1) = 1 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + LENG(I) END DO CALL MUMPS_733(TSENDI, max(TOP_CNT,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(TSENDJ, max(TOP_CNT,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT tsendi:',MEMCNT,MAXMEM #endif LENG(:) = 0 CALL SMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) NEW_LOCNNZ = sum(RCVCNT) DO I=1, NPROCS MSGCNT(I) = RCVCNT(I)/BUFSIZE END DO CALL MUMPS_733(PE, max(NEW_LOCNNZ+2*NROWS_LOC,1), id%INFO, & LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe2:',MEMCNT,MAXMEM #endif RCVPNT = 1 SNDCNT = 0 TIDX = 0 DO I=1, id%NZ_loc IF(mod(I,BUFSIZE/10) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, MPI_COMM_WORLD, STATUS, IERR) CALL SMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(I) TSENDJ(TIDX) = id%JCN_loc(I) ELSE IIDX = ord%PERMTAB(id%IRN_loc(I)) JJDX = ord%PERMTAB(id%JCN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) =IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%JCN_loc(I) END IF SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(I)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(I) TSENDJ(TIDX) = id%IRN_loc(I) ELSE IIDX = ord%PERMTAB(id%JCN_loc(I)) JJDX = ord%PERMTAB(id%IRN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%IRN_loc(I) END IF SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF END IF END DO CALL SMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO J=IPE(I),IPE(I+1)-1 IF(PE(J) .LT. 0) THEN IF(HALO_MAP(-PE(J)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(J)) = NROWS_LOC+HALO_SIZE END IF PE(J) = HALO_MAP(-PE(J)) END IF IF(MAPTAB(PE(J)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_733(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT i_halo:',MEMCNT,MAXMEM #endif 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_733(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_733(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT lengipe:',MEMCNT, & MAXMEM #endif 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_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) RDISPL => MSGCNT NULLIFY(MSGCNT) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) RDISPL(1) = 0 DO I=2, NPROCS RDISPL(I) = RDISPL(I-1)+RCVCNT(I-1) END DO top_graph%NZ_LOC = NEW_LOCNNZ top_graph%COMM = id%COMM CALL MUMPS_733(top_graph%IRN_LOC, NEW_LOCNNZ, id%INFO, & LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(top_graph%JCN_LOC, NEW_LOCNNZ, id%INFO, & LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT top_graph:',MEMCNT, & MAXMEM #endif ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1)) END IF CALL MPI_GATHERV(TSENDI(1), TOP_CNT, MPI_INTEGER, & top_graph%IRN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, & 0, id%COMM, IERR) CALL MPI_GATHERV(TSENDJ(1), TOP_CNT, MPI_INTEGER, & top_graph%JCN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, & 0, id%COMM, IERR) CALL MUMPS_734(SNDCNT, RCVCNT, RDISPL, & TSENDI, TSENDJ, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM #endif DEALLOCATE(APNT) RETURN END SUBROUTINE SMUMPS_775 SUBROUTINE SMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER :: NPROCS, PROC, COMM TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:), IPE(:) INTEGER :: MSGCNT(:), SNDCNT(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE, TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE), & 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_773(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_773(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_773(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_785 SUBROUTINE SMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) #ifdef MPELOG USE MPEMOD INCLUDE 'mpif.h' #endif IMPLICIT NONE INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), IPE(:), PE(:), LENG(:) INTEGER :: I, ROW, COL #ifdef MPELOG INTEGER ::IERR IERR = MPE_LOG_EVENT( MPE_ASM_BUF1, 0, '' ) #endif 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 #ifdef MPELOG IERR = MPE_LOG_EVENT( MPE_ASM_BUF2, 0, '' ) #endif RETURN END SUBROUTINE SMUMPS_773 SUBROUTINE SMUMPS_777(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_777 SUBROUTINE SMUMPS_784(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_784 SUBROUTINE SMUMPS_783(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_783 FUNCTION MUMPS_795(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_795 IF(associated(A)) THEN MUMPS_795 = size(A) ELSE MUMPS_795 = 0 END IF RETURN END FUNCTION MUMPS_795 SUBROUTINE MUMPS_734(A1, A2, A3, A4, A5, A6, A7, MEMCNT) INTEGER, POINTER :: A1(:) INTEGER, POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:), & A6(:), A7(:) INTEGER, OPTIONAL :: MEMCNT INTEGER :: IMEMCNT IMEMCNT = 0 IF(associated(A1)) THEN IMEMCNT = IMEMCNT+size(A1) DEALLOCATE(A1) END IF IF(present(A2)) THEN IF(associated(A2)) THEN IMEMCNT = IMEMCNT+size(A2) DEALLOCATE(A2) END IF END IF IF(present(A3)) THEN IF(associated(A3)) THEN IMEMCNT = IMEMCNT+size(A3) DEALLOCATE(A3) END IF END IF IF(present(A4)) THEN IF(associated(A4)) THEN IMEMCNT = IMEMCNT+size(A4) DEALLOCATE(A4) END IF END IF IF(present(A5)) THEN IF(associated(A5)) THEN IMEMCNT = IMEMCNT+size(A5) DEALLOCATE(A5) END IF END IF IF(present(A6)) THEN IF(associated(A6)) THEN IMEMCNT = IMEMCNT+size(A6) DEALLOCATE(A6) END IF END IF IF(present(A7)) THEN IF(associated(A7)) THEN IMEMCNT = IMEMCNT+size(A7) DEALLOCATE(A7) END IF END IF IF(present(MEMCNT)) MEMCNT = MEMCNT-IMEMCNT RETURN END SUBROUTINE MUMPS_734 #if defined(memprof) FUNCTION ESTIMEM(MYID, N, NZR) INTEGER :: ESTIMEM, MYID, NZR, N IF(MYID.EQ.0) THEN ESTIMEM = 12*N ELSE ESTIMEM = 7*N END IF IF(MYID.NE.0) TOPROWS=0 IF(MYID .EQ. 0) ESTIMEM = ESTIMEM+2*TOPROWS*NZR ESTIMEM = ESTIMEM+NRL ESTIMEM = ESTIMEM+max(NRL,TOPROWS)*(NZR+2) ESTIMEM = ESTIMEM+6*max(NRL,TOPROWS) IF(MYID.EQ.0) ESTIMEM=ESTIMEM+3*TOPROWS RETURN END FUNCTION ESTIMEM #endif END MODULE SUBROUTINE SMUMPS_448(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_448 SUBROUTINE SMUMPS_444 & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER M,N,NE,NUM INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),PR(N),Q(M),L(M) REAL A(NE) REAL D(M), RINF INTEGER I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & K,KK,KK1,KK2,I0,UP,LOW 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_445, SMUMPS_446, SMUMPS_447, SMUMPS_455 RLX = D(1) NUM = 0 BV = RINF DO 10 K = 1,N JPERM(K) = 0 PR(K) = IP(K) 10 CONTINUE DO 12 K = 1,M IPERM(K) = 0 D(K) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1 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 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 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 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1 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 DO 115 K = IP(J),IP(J+1)-1 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_445(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = J 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_446(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 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_447(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_445(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = J 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 = PR(J) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 KK = UP,M I = Q(KK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 KK = LOW,UP-1 I = Q(KK) D(I) = MINONE 192 CONTINUE DO 193 KK = 1,QLEN I = Q(KK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL SMUMPS_455(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE SMUMPS_444 SUBROUTINE SMUMPS_445(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_445 SUBROUTINE SMUMPS_446(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_446 SUBROUTINE SMUMPS_447(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_447 SUBROUTINE SMUMPS_450(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER WLEN,NVAL INTEGER IP(*),LENL(*),LENH(*),W(*) REAL A(*),VAL INTEGER XX,J,K,II,S,POS PARAMETER (XX=10) REAL SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+LENL(J),IP(J)+LENH(J)-1 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_450 SUBROUTINE SMUMPS_451(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER N,NE INTEGER IP(N+1),IRN(NE) REAL A(NE) INTEGER THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER J,IPJ,K,LEN,R,S,HI,FIRST,MID,LAST,TD REAL HA,KEY INTEGER TODO(TDLEN) DO 100 J = 1,N LEN = 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 + LEN TD = 2 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 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 425 CONTINUE IF (TD.EQ.0) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.THRESH) GO TO 500 TD = TD - 2 GO TO 425 400 DO 200 R = IPJ+1,IPJ+LEN-1 IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1) IRN(R) = IRN(R-1) DO 300 S = R-1,IPJ+1,-1 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_451 SUBROUTINE SMUMPS_452(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER M,N,NE,NUMX INTEGER IP(N+1),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,II,I,J,K,L,CNT,MOD,IDUM1,IDUM2,IDUM3 REAL BVAL,BMIN,BMAX EXTERNAL SMUMPS_450,SMUMPS_453,SMUMPS_455 DO 20 J = 1,N FC(J) = J LEN(J) = 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_453(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 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 = IP(J+1) - IP(J) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = K - IP(J) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 IDUM1 = 1,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 IDUM2 = 1,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL SMUMPS_450(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM3 = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+LEN(J)-1,IP(J)+LENL(J),-1 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) = 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_450(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM3 = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+LEN(J),IP(J)+LENH(J)-1 IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = 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_453(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_455(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE SMUMPS_452 SUBROUTINE SMUMPS_453 & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER ID,MOD,M,N,LIRN,NUM,NUMX INTEGER ARP(N),CV(M),IRN(LIRN),IP(N), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK,LAST,NFC, & NUM0,NUM1,NUM2,ID0,ID1 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) + ARP(J) IN2 = IP(J) + LENC(J) - 1 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 = OUT(J) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + LENC(J) - 1 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) = 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) = 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) + LENC(J) - OUT(J) - 2 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_453 SUBROUTINE SMUMPS_454(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER M,N,NE,NUM INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),OUT(N),PR(N),Q(M),L(M) REAL A(NE),U(M),D(M),RINF,RINF3 INTEGER I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,ISP,JSP, & K,K0,K1,K2,KK,KK1,KK2,UP,LOW REAL CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL LORD REAL ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) EXTERNAL SMUMPS_445, SMUMPS_446, SMUMPS_447, SMUMPS_455 RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 K = 1,N JPERM(K) = 0 PR(K) = IP(K) D(K) = RINF 10 CONTINUE DO 15 K = 1,M U(K) = RINF3 IPERM(K) = 0 L(K) = 0 15 CONTINUE DO 30 J = 1,N IF (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) 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 K = 1,M D(K) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1 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 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 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF L(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 DO 115 K = IP(J),IP(J+1)-1 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 Q(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 KK = 1,Q0 K = Q(KK) 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 Q(LOW) = I L(I) = LOW ELSE QLEN = QLEN + 1 L(I) = QLEN CALL SMUMPS_445(I,M,Q,D,L,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = J 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL SMUMPS_446(QLEN,M,Q,D,L,2) LOW = LOW - 1 Q(LOW) = I L(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = Q(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 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 (L(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 (L(I).NE.0) THEN CALL SMUMPS_447(L(I),QLEN,M,Q,D,L,2) ENDIF LOW = LOW - 1 Q(LOW) = I L(I) = LOW ELSE IF (L(I).EQ.0) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL SMUMPS_445(I,M,Q,D,L,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = J 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 = 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 KK = UP,M I = Q(KK) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 KK = UP,M I = Q(KK) D(I) = RINF L(I) = 0 191 CONTINUE DO 192 KK = LOW,UP-1 I = Q(KK) D(I) = RINF L(I) = 0 192 CONTINUE DO 193 KK = 1,QLEN I = Q(KK) D(I) = RINF L(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_455(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE SMUMPS_454 SUBROUTINE SMUMPS_457 & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER LIRN,M,N,NUM INTEGER ARP(N),CV(M),IRN(LIRN),IP(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK EXTERNAL SMUMPS_455 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 = ARP(J) IF (IN1.LT.0) GO TO 30 IN2 = IP(J) + LENC(J) - 1 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 = OUT(J) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + LENC(J) - 1 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) = IN2 - II - 1 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) = IN2 - II - 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 1000 II = IP(J) + LENC(J) - OUT(J) - 2 I = IRN(II) IPERM(I) = J 90 CONTINUE 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL SMUMPS_455(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE SMUMPS_457 SUBROUTINE SMUMPS_455(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_455 mumps-4.10.0.dfsg/src/dmumps_struc_def.F0000644000175300017530000000430311562233066020346 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE DMUMPS_STRUC_DEF INCLUDE 'dmumps_struc.h' END MODULE DMUMPS_STRUC_DEF mumps-4.10.0.dfsg/src/zmumps_part4.F0000644000175300017530000071711411562233070017456 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE ZMUMPS_246(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 & ) IMPLICIT NONE 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 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_748 EXTERNAL ZMUMPS_748 INTEGER MUMPS_275, MUMPS_330 LOGICAL MUMPS_170 INTEGER MUMPS_52 EXTERNAL MUMPS_503, MUMPS_52 EXTERNAL MUMPS_275, MUMPS_330, & MUMPS_170 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)) 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 = dble(0.0D0) ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = dble(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_275(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_246 ' 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_275(PROCNODE(STEP(INODE)),SLAVEF) & .EQ. MYID LEVEL = MUMPS_330(PROCNODE(STEP(INODE)),SLAVEF) INSSARBR = MUMPS_170(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_503(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_170( & 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_748( & 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_748( & 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 = NRLADU + int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU = NRLADU + int(NELIM,8)*int(NCB/NSLAVES_LOC,8) ENDIF NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) 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_246. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_275(PROCNODE(STEP(IFSON)),SLAVEF) & .EQ.MYID LEVELSON = MUMPS_330(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_246. 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_511(NFR, & NELIM, NELIM,0, & 1,OPS_NODE) ELSE CALL MUMPS_511(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_511(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 ) & ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN OPSA_LOC = OPSA_LOC + OPS_NODE / dble( SLAVEF ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(SLAVEF,8) IF (MASTER) & ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) 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_170(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_511(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_330(PROCNODE(STEP(IFATH)),SLAVEF) MASTERF= MUMPS_275(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_503( 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_246' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in ZMUMPS_246 ' 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_246 RECURSIVE SUBROUTINE & ZMUMPS_271( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 40 ) INTEGER(8) KEEP8(150) 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(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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(max(1,KEEP(14))) COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.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, & STATUS( MPI_STATUS_SIZE ), ISON, PDEST_MASTER_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL INVERT INCLUDE 'mumps_headers.h' INTEGER MUMPS_275, MUMPS_330 EXTERNAL MUMPS_275, MUMPS_330 FPERE = KEEP(38) TYPE_SON = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( MUMPS_275( 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_271 ', 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_80( 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, .FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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 INVERT = .FALSE. ELSE INVERT = .TRUE. END IF CALL ZMUMPS_80( 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_93(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_275(PROCNODE_STEPS(STEP(ISON)), SLAVEF) DO WHILE ( PTRIST(STEP(ISON)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & PDEST_MASTER_ISON, MAITRE_DESC_BANDE, & 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) RETURN ENDDO DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_271 ' 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 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_271", & IW(IOLDPS+XXS), "INODE=",INODE CALL MUMPS_ABORT() ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN INVERT = .FALSE. ELSE INVERT = .TRUE. END IF CALL ZMUMPS_80( 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL ZMUMPS_314( 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, TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL ZMUMPS_44( MYID, SLAVEF, COMM ) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_271 SUBROUTINE ZMUMPS_221(NFRONT,NASS,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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW INTEGER(8) :: LA COMPLEX(kind=8) A(LA) DOUBLE PRECISION UU, SEUIL INTEGER IW(LIW) INTEGER(8) :: POSELT INTEGER IOLDPS INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INCLUDE 'mumps_headers.h' COMPLEX(kind=8) SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, J3, JJ INTEGER(8) :: NFRONT8 DOUBLE PRECISION AMROW DOUBLE PRECISION RMAX DOUBLE PRECISION PIVNUL COMPLEX(kind=8) FIXA, CSEUIL INTEGER NPIV,NASSW,IPIV INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW INTEGER ZMUMPS_IXAMAX INTRINSIC max DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0, 0.0D0) INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U PIVNUL = DKEEP(1) FIXA = cmplx( DKEEP(2), kind=kind(FIXA)) CSEUIL = cmplx( SEUIL, kind=kind(CSEUIL)) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NFRONT8 = int(NFRONT,8) IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL ZMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_680( 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 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF (UU.GT.RZERO) GO TO 340 IF (abs(A(APOS)).EQ.RZERO) GO TO 630 GO TO 380 340 AMROW = RZERO J1 = APOS J2 = APOS + int(- NPIV + NASS - 1,8) J = NASS -NPIV JMAX = ZMUMPS_IXAMAX(J,A(J1),1) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW J1 = J2 + 1_8 J2 = APOS +int(- NPIV + NFRONT - 1 - KEEP(253),8) IF (J2.LT.J1) GO TO 370 DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF ( RMAX .LE. PIVNUL ) THEN KEEP(109) = KEEP(109)+1 ISW = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE+ & IW(IOLDPS+5+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)).GT. max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE. max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_762( & 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 + 5 + NPIVP1 + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + 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) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + 5 + NFRONT + NPIV + 1 +XSIZE ISWPS2 = IOLDPS + 5 + NFRONT + NPIV + JMAX +XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 WRITE(*,*) 'Detected a null pivot, INODE/NPIV=',INODE,NPIV GOTO 430 420 CONTINUE IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_680( 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_221 SUBROUTINE ZMUMPS_220(NFRONT,NASS,N,INODE,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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,INOPV INTEGER(8) :: LA INTEGER KEEP(500) DOUBLE PRECISION DKEEP(30) DOUBLE PRECISION UU, SEUIL COMPLEX(kind=8) A(LA) INTEGER IW(LIW) DOUBLE PRECISION AMROW DOUBLE PRECISION RMAX COMPLEX(kind=8) SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NOFFW,NPIV,IPIV 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 ZMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL ZMUMPS_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL ZMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF DO 460 IPIV=NPIVP1,NASS APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = ZMUMPS_IXAMAX(J3,A(J1),NFRONT) 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 (J3.EQ.0) GOTO 370 DO 360 J=1,J3 RMAX = max(abs(A(J1)),RMAX) J1 = J1 + NFRONT8 360 CONTINUE 370 IF (RMAX.EQ.RZERO) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)).GE.max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LT.max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_762( & 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 390 J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 390 CONTINUE 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 410 KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 410 CONTINUE 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_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_680( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE ZMUMPS_220 SUBROUTINE ZMUMPS_225(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_225 SUBROUTINE ZMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA,IOLDPS, & POSELT,XSIZE) IMPLICIT NONE INTEGER NFRONT,N,INODE,LIW,XSIZE INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) COMPLEX(kind=8) ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS INTEGER(8) :: NFRONT8, LPOS, IRWPOS INTEGER IOLDPS,NPIV,NEL INTEGER JROW INCLUDE 'mumps_headers.h' COMPLEX(kind=8), PARAMETER :: ONE=(1.0D0,0.0D0) NFRONT8= int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NEL = NFRONT - NPIV - 1 APOS = POSELT + int(NPIV,8) * NFRONT8 + int(NPIV,8) IF (NEL.EQ.0) GO TO 650 VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 340 JROW = 1,NEL A(LPOS) = VALPIV*A(LPOS) LPOS = LPOS + NFRONT8 340 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS+1_8 DO 440 JROW = 1,NEL IRWPOS = LPOS + 1_8 ALPHA = -A(LPOS) CALL zaxpy(NEL,ALPHA,A(UUPOS),1,A(IRWPOS),1) LPOS = LPOS + NFRONT8 440 CONTINUE 650 RETURN END SUBROUTINE ZMUMPS_229 SUBROUTINE ZMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,N,LIW,INODE,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,KROW, XSIZE INTEGER NEL,ICOL,NEL2 INTEGER NPIVP1 COMPLEX(kind=8), PARAMETER :: ONE=(1.0D0,0.0D0) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 DO 440 ICOL = 1,NEL IRWPOS = LPOS + 1_8 ALPHA = -A(LPOS) CALL zaxpy(NEL2,ALPHA,A(UUPOS),1,A(IRWPOS),1) LPOS = LPOS + NFRONT8 440 CONTINUE RETURN END SUBROUTINE ZMUMPS_228 SUBROUTINE ZMUMPS_231(A,LA,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER(8) :: LA,POSELT COMPLEX(kind=8) A(LA) INTEGER NFRONT, NPIV, NASS INTEGER(8) :: LPOS, LPOS1, LPOS2 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) 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_231 SUBROUTINE ZMUMPS_642(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_688 & ( 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_642 SUBROUTINE ZMUMPS_232(A,LA,NFRONT,NPIV,NASS,POSELT,LKJIB) INTEGER NFRONT, NPIV, NASS, LKJIB INTEGER (8) :: POSELT, LA COMPLEX(kind=8) A(LA) INTEGER(8) :: POSELT_LOCAL, LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPBEG COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) POSELT_LOCAL = POSELT NEL1 = NASS - NPIV NPBEG = NPIV - LKJIB + 1 NEL11 = NFRONT - NPIV LPOS2 = POSELT_LOCAL + int(NPIV,8)*int(NFRONT,8) & + int(NPBEG - 1,8) POSELT_LOCAL = POSELT_LOCAL + int(NPBEG-1,8)*int(NFRONT,8) & + int(NPBEG-1,8) CALL ztrsm('L','L','N','N',LKJIB,NEL1,ONE,A(POSELT_LOCAL), & NFRONT,A(LPOS2),NFRONT) LPOS = LPOS2 + int(LKJIB,8) LPOS1 = POSELT_LOCAL + int(LKJIB,8) CALL zgemm('N','N',NEL11,NEL1,LKJIB,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE ZMUMPS_232 SUBROUTINE ZMUMPS_233(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT,XSIZE ) IMPLICIT NONE INTEGER NFRONT, NASS,N,LIW INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG,LKJIB, INODE, IBEG_BLOCK INTEGER(8) :: POSELT, LPOS, LPOS1, LPOS2, POSLOCAL INTEGER(8) :: IPOS, KPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1, NEL11 INTEGER LBP, HF INTEGER LBPT,I1,K1,II,ISWOP,LBP1 INTEGER LKJIT, XSIZE INCLUDE 'mumps_headers.h' COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) JROW2 = iabs(IW(IOLDPS+3+XSIZE)) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+XSIZE) +XSIZE NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+XSIZE)= min0(NPIV+LKJIB,NASS) ELSE IW(IOLDPS+3+XSIZE) = NASS ENDIF IBEG_BLOCK = NPIV + 1 NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 NEL11 = NFRONT - NPIV IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN LPOS2 = POSELT + int(JROW2,8)*NFRONT8 + & int(NPBEG - 1,8) POSLOCAL = POSELT + int(NPBEG-1,8)*NFRONT8 + int(NPBEG - 1,8) CALL ztrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSLOCAL),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSLOCAL + int(LKJIW,8) CALL zgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF RETURN END SUBROUTINE ZMUMPS_233 SUBROUTINE ZMUMPS_236(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_236 SUBROUTINE ZMUMPS_217(N, NZ, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NZ, NSCA INTEGER IRN(NZ), ICN(NZ) INTEGER ICNTL(40), INFO(40) COMPLEX(kind=8) ASPK(NZ) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER LWK, LWK_REAL COMPLEX(kind=8) WK(LWK) DOUBLE PRECISION WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER IWNOR INTEGER I, K LOGICAL PROK DOUBLE PRECISION ONE PARAMETER( ONE = 1.0D0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROK = (MPG.GT.0) IF (PROK) WRITE(MPG,101) 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROK) & WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.2) THEN IF (PROK) & WRITE (MPG,*) ' SCALING BASED ON (MC29)' 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)' ELSEIF (NSCA.EQ.5) THEN IF (PROK) & WRITE (MPG,*) ' MC29 FOLLOWED BY ROW &COL SCALING' ELSEIF (NSCA.EQ.6) THEN IF (PROK) & WRITE (MPG,*) ' MC29 FOLLOWED BY COLUMN SCALING' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF ((NSCA.EQ.5).OR. & (NSCA.EQ.6)) THEN IF (NZ.GT.LWK) GOTO 400 DO 15 K=1,NZ WK(K) = ASPK(K) 15 CONTINUE ENDIF IF (5*N.GT.LWK_REAL) GOTO 410 IWNOR = 1 IF (NSCA.EQ.1) THEN CALL ZMUMPS_238(N,NZ,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.2) THEN CALL ZMUMPS_239(N,NZ,ASPK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) ELSEIF (NSCA.EQ.3) THEN CALL ZMUMPS_241(N,NZ,ASPK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN CALL ZMUMPS_287(N,NZ,IRN,ICN,ASPK, & WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.5) THEN CALL ZMUMPS_239(N,NZ,WK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) CALL ZMUMPS_241(N,NZ,WK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.6) THEN CALL ZMUMPS_239(N,NZ,WK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) CALL ZMUMPS_240(NSCA,N,NZ,IRN,ICN,WK, & WK_REAL(IWNOR+N),ROWSCA,MPG) CALL ZMUMPS_241(N,NZ,WK,IRN,ICN, & WK_REAL(IWNOR), COLSCA, MPG) ENDIF GOTO 500 400 INFO(1) = -5 INFO(2) = NZ-LWK IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' 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_217 SUBROUTINE ZMUMPS_287(N,NZ,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER N, NZ COMPLEX(kind=8) VAL(NZ) DOUBLE PRECISION RNOR(N),CNOR(N) DOUBLE PRECISION COLSCA(N),ROWSCA(N) DOUBLE PRECISION CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ), ICN(NZ) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J,K 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 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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_287 SUBROUTINE ZMUMPS_239(N,NZ,VAL,ROWIND,COLIND, & RNOR,CNOR,WNOR,MPRINT,MP, & NSCA) INTEGER N, NZ COMPLEX(kind=8) VAL(NZ) DOUBLE PRECISION WNOR(5*N) DOUBLE PRECISION RNOR(N), CNOR(N) INTEGER COLIND(NZ),ROWIND(NZ) INTEGER J,I,K INTEGER MPRINT,MP,NSCA INTEGER IFAIL9 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0) DO 15 I=1,N RNOR(I) = ZERO CNOR(I) = ZERO 15 CONTINUE CALL ZMUMPS_216(N,N,NZ,VAL,ROWIND,COLIND, & RNOR,CNOR,WNOR, MP,IFAIL9) *CVD$ NODEPCHK *CVD$ VECTOR *CVD$ CONCUR DO 30 I=1,N CNOR(I) = exp(CNOR(I)) RNOR(I) = exp(RNOR(I)) 30 CONTINUE IF ((NSCA.EQ.5).OR.(NSCA.EQ.6)) THEN DO 100 K=1,NZ I = ROWIND(K) J = COLIND(K) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 100 VAL(K) = VAL(K) * CNOR(J) * RNOR(I) 100 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING USING MC29' RETURN END SUBROUTINE ZMUMPS_239 SUBROUTINE ZMUMPS_241(N,NZ,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER N,NZ COMPLEX(kind=8) VAL(NZ) DOUBLE PRECISION CNOR(N) DOUBLE PRECISION COLSCA(N) INTEGER IRN(NZ), ICN(NZ) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J,K DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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_241 SUBROUTINE ZMUMPS_238(N,NZ,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER N, NZ COMPLEX(kind=8) VAL(NZ) DOUBLE PRECISION ROWSCA(N),COLSCA(N) INTEGER IRN(NZ),ICN(NZ) DOUBLE PRECISION VDIAG INTEGER MPRINT,I,J,K 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 K=1,NZ I = IRN(K) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K) IF (I.EQ.J) THEN VDIAG = abs(VAL(K)) 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_238 SUBROUTINE ZMUMPS_240(NSCA,N,NZ,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER N, NZ, NSCA INTEGER IRN(NZ), ICN(NZ) COMPLEX(kind=8) VAL(NZ) DOUBLE PRECISION RNOR(N) DOUBLE PRECISION ROWSCA(N) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J,K DOUBLE PRECISION ZERO,ONE PARAMETER (ZERO=0.0D0, ONE=1.0D0) DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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 K=1,NZ I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K) = VAL(K) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE ZMUMPS_240 SUBROUTINE ZMUMPS_216(M,N,NE,A,IRN,ICN,R,C,W,LP,IFAIL) INTEGER M,N,NE COMPLEX(kind=8) A(NE) INTEGER IRN(NE),ICN(NE) DOUBLE PRECISION R(M),C(N) DOUBLE PRECISION W(M*2+N*3) INTEGER LP,IFAIL INTRINSIC log,abs,min INTEGER MAXIT PARAMETER (MAXIT=100) DOUBLE PRECISION ONE DOUBLE PRECISION SMIN,ZERO PARAMETER (ONE=1.0D0,SMIN=0.1D0,ZERO=0.0D0) INTEGER I,I1,I2,I3,I4,I5,ITER,J,K DOUBLE PRECISION E,E1,EM,Q,Q1,QM,S,S1,SM,U,V IFAIL = 0 IF (M.LT.1 .OR. N.LT.1) THEN IFAIL = -1 GO TO 220 ELSE IF (NE.LE.0) THEN IFAIL = -2 GO TO 220 END IF I1 = 0 I2 = M I3 = M + N I4 = M + N*2 I5 = M + N*3 DO 10 I = 1,M R(I) = ZERO W(I1+I) = ZERO 10 CONTINUE DO 20 J = 1,N C(J) = ZERO W(I2+J) = ZERO W(I3+J) = ZERO W(I4+J) = ZERO 20 CONTINUE DO 30 K = 1,NE U = abs(A(K)) IF (U.EQ.ZERO) GO TO 30 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 30 U = log(U) W(I1+I) = W(I1+I) + ONE W(I2+J) = W(I2+J) + ONE R(I) = R(I) + U W(I3+J) = W(I3+J) + U 30 CONTINUE DO 40 I = 1,M IF (W(I1+I).EQ.ZERO) W(I1+I) = ONE R(I) = R(I)/W(I1+I) W(I5+I) = R(I) 40 CONTINUE DO 50 J = 1,N IF (W(I2+J).EQ.ZERO) W(I2+J) = ONE W(I3+J) = W(I3+J)/W(I2+J) 50 CONTINUE SM = SMIN*dble(NE) DO 60 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 60 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 60 R(I) = R(I) - W(I3+J)/W(I1+I) 60 CONTINUE E = ZERO Q = ONE S = ZERO DO 70 I = 1,M S = S + W(I1+I)*R(I)**2 70 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 160 DO 150 ITER = 1,MAXIT DO 80 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 80 J = ICN(K) I = IRN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 80 C(J) = C(J) + R(I) 80 CONTINUE S1 = S S = ZERO DO 90 J = 1,N V = -C(J)/Q C(J) = V/W(I2+J) S = S + V*C(J) 90 CONTINUE E1 = E E = Q*S/S1 Q = ONE - E IF (abs(S).LE.abs(SM)) E = ZERO DO 100 I = 1,M R(I) = R(I)*E*W(I1+I) 100 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 180 EM = E*E1 DO 110 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 110 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 110 R(I) = R(I) + C(J) 110 CONTINUE S1 = S S = ZERO DO 120 I = 1,M V = -R(I)/Q R(I) = V/W(I1+I) S = S + V*R(I) 120 CONTINUE E1 = E E = Q*S/S1 Q1 = Q Q = ONE - E IF (abs(S).LE.abs(SM)) Q = ONE QM = Q*Q1 DO 130 J = 1,N W(I4+J) = (EM*W(I4+J)+C(J))/QM W(I3+J) = W(I3+J) + W(I4+J) 130 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 160 DO 140 J = 1,N C(J) = C(J)*E*W(I2+J) 140 CONTINUE 150 CONTINUE 160 DO 170 I = 1,M R(I) = R(I)*W(I1+I) 170 CONTINUE 180 DO 190 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 190 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 190 R(I) = R(I) + W(I3+J) 190 CONTINUE DO 200 I = 1,M R(I) = R(I)/W(I1+I) - W(I5+I) 200 CONTINUE DO 210 J = 1,N C(J) = -W(I3+J) 210 CONTINUE RETURN 220 IF (LP.GT.0) WRITE (LP,'(/A/A,I3)') & ' **** Error return from ZMUMPS_216 ****',' IFAIL =',IFAIL END SUBROUTINE ZMUMPS_216 SUBROUTINE ZMUMPS_27( 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_207(id%A(1), & id%NZ, id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL ZMUMPS_289(id%A(1), & id%NZ, 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_119(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL ZMUMPS_135(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, 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%NZ_loc .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL ZMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1) ) ELSE CALL ZMUMPS_289(id%A_loc(1), & id%NZ_loc, 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_27 SUBROUTINE ZMUMPS_693(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, M, 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 RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) INTEGER ISZWRKRC DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION ONENORMERR,INFNORMERR INTEGER SYM, NB1, NB2, NB3 DOUBLE PRECISION EPS EXTERNAL ZMUMPS_694,ZMUMPS_687, & ZMUMPS_670 INTEGER I IF(SYM.EQ.0) THEN CALL ZMUMPS_694(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_687(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_693 SUBROUTINE ZMUMPS_694(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, M, 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 RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) INTEGER ISZWRKRC DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION ONENORMERR,INFNORMERR INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC 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 INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS INTEGER ITER, NZIND, IR, IC DOUBLE PRECISION ELM 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) EXTERNAL ZMUMPS_654, & ZMUMPS_672, & ZMUMPS_674, & ZMUMPS_662, & ZMUMPS_743, & ZMUMPS_745, & ZMUMPS_660, & ZMUMPS_670, & ZMUMPS_671, & ZMUMPS_657, & ZMUMPS_656 INTEGER ZMUMPS_743 INTEGER ZMUMPS_745 DOUBLE PRECISION ZMUMPS_737 DOUBLE PRECISION ZMUMPS_738 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) 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 IF(OP == 1) THEN IF(NUMPROCS > 1) THEN CALL ZMUMPS_654(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ) CALL ZMUMPS_654(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ) CALL ZMUMPS_672(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_672(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_662(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 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0 ENDIF RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL RESZ = RESZR + RESZC 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 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 CALL ZMUMPS_660(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 IRNGHBPRCS = IMYCPTR+ INUMMYC IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1 OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM OCSNDRCVJA = OCSNDRCVIA + NUMPROCS + 1 REQUESTS = OCSNDRCVJA + OCSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL ZMUMPS_674(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_674(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_670(ROWSCA, M, RZERO) CALL ZMUMPS_670(COLSCA, N, RZERO) CALL ZMUMPS_671(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE) CALL ZMUMPS_671(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE) ELSE CALL ZMUMPS_670(ROWSCA, M, RONE) CALL ZMUMPS_670(COLSCA, N, RONE) ENDIF ITDRPTR = 1 ITDCPTR = ITDRPTR + M ISRRPTR = ITDCPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL ISRCPTR = OSRRPTR + ORSNDRCVVOL OSRCPTR = ISRCPTR + ICSNDRCVVOL IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1 ISRCPTR = ISRCPTR - 1 OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) IF(NUMPROCS > 1) THEN CALL ZMUMPS_650(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) CALL ZMUMPS_650(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) ELSE CALL ZMUMPS_670(WRKRC(ITDRPTR),M, RZERO) CALL ZMUMPS_670(WRKRC(ITDCPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1,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_657(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) CALL ZMUMPS_657(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_737(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) INFERRCOL = ZMUMPS_737(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_665(COLSCA, WRKRC(ITDCPTR), & N, & IWRK(IMYCPTR),INUMMYC) CALL ZMUMPS_665(ROWSCA, WRKRC(ITDRPTR), & M, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = ZMUMPS_738(ROWSCA, & WRKRC(ITDRPTR), M) INFERRCOL = ZMUMPS_738(COLSCA, & WRKRC(ITDCPTR), N) INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL ZMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE IF((ITER .EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1,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_656(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) CALL ZMUMPS_656(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_737(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) ONEERRCOL = ZMUMPS_737(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_665(COLSCA, WRKRC(ITDCPTR), & N, & IWRK(IMYCPTR),INUMMYC) CALL ZMUMPS_665(ROWSCA, WRKRC(ITDRPTR), & M, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = ZMUMPS_738(ROWSCA, & WRKRC(ITDRPTR), M) ONEERRCOL = ZMUMPS_738(COLSCA, & WRKRC(ITDCPTR), N) ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL ZMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL ZMUMPS_665(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) CALL ZMUMPS_665(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) ELSE CALL ZMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL ZMUMPS_666(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 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_694 SUBROUTINE ZMUMPS_687(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, 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) INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ISRRPTR, OSRRPTR DOUBLE PRECISION ONENORMERR,INFNORMERR INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS INTEGER ITER, NZIND, IR, IC DOUBLE PRECISION ELM INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) EXTERNAL ZMUMPS_655, & ZMUMPS_673, & ZMUMPS_692, & ZMUMPS_663, & ZMUMPS_742, & ZMUMPS_745, & ZMUMPS_661, & ZMUMPS_657, & ZMUMPS_656, & ZMUMPS_670, & ZMUMPS_671 INTEGER ZMUMPS_742 INTEGER ZMUMPS_745 DOUBLE PRECISION ZMUMPS_737 DOUBLE PRECISION ZMUMPS_738 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) 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 CALL ZMUMPS_655(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ) CALL ZMUMPS_673(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc,JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL ZMUMPS_663(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWRKSZ) INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZ = INTSZR + N + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0 ENDIF RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) INUMMYR = REGISTRE(9) IF(NUMPROCS > 1) THEN CALL ZMUMPS_661(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-INUMMYR) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 REQUESTS = ORSNDRCVJA + ORSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL ZMUMPS_692(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_670(SCA, N, RZERO) CALL ZMUMPS_671(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE) ELSE CALL ZMUMPS_670(SCA, N, RONE) ENDIF ITDRPTR = 1 ISRRPTR = ITDRPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) IF(NUMPROCS > 1) THEN CALL ZMUMPS_650(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL ZMUMPS_670(WRKRC(ITDRPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1,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_657(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_737(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_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = ZMUMPS_738(SCA, & WRKRC(ITDRPTR), N) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_666(SCA, WRKRC(ITDRPTR), N) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1,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,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_656(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_737(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = ZMUMPS_738(SCA, & WRKRC(ITDRPTR), N) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_666(SCA, WRKRC(ITDRPTR), N) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL ZMUMPS_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL ZMUMPS_666(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_687 SUBROUTINE ZMUMPS_654(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL ZMUMPS_703 INTEGER MYID, NUMPROCS, COMM INTEGER NZ_loc, ISZ, IWSZ, OSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWSZ) INCLUDE 'mpif.h' INTEGER I INTEGER OP, IERROR INTEGER IR, IC IF(NUMPROCS.NE.1) THEN CALL MPI_OP_CREATE(ZMUMPS_703, .TRUE., OP, IERROR) CALL ZMUMPS_668(IWRK, 4*ISZ, ISZ) DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_654 SUBROUTINE ZMUMPS_662(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, M, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER INUMMYR, INUMMYC INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC INUMMYR = 0 INUMMYC = 0 DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRK(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I=1,NZ_loc IC = JCN_loc(I) IR = IRN_loc(I) 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 RETURN END SUBROUTINE ZMUMPS_662 SUBROUTINE ZMUMPS_660(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, 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 INTEGER I, IR, IC, ITMP, MAXMN MAXMN = M IF(N > MAXMN) MAXMN = N DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_660 INTEGER FUNCTION ZMUMPS_744(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION EPS INTEGER I, IID DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) ZMUMPS_744 = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN ZMUMPS_744 = 0 ENDIF ENDDO RETURN END FUNCTION ZMUMPS_744 INTEGER FUNCTION ZMUMPS_745(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION EPS INTEGER I DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) ZMUMPS_745 = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN ZMUMPS_745 = 0 ENDIF ENDDO RETURN END FUNCTION ZMUMPS_745 INTEGER FUNCTION ZMUMPS_743(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_744 INTEGER ZMUMPS_744 INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = ZMUMPS_744(DR, M, INDXR, INDXRSZ, EPS) MYRESC = ZMUMPS_744(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) ZMUMPS_743 = GLORES RETURN END FUNCTION ZMUMPS_743 DOUBLE PRECISION FUNCTION ZMUMPS_737(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) 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_737 = ERRMAX RETURN END FUNCTION ZMUMPS_737 DOUBLE PRECISION FUNCTION ZMUMPS_738(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) 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_738 = ERRMAX1 RETURN END FUNCTION ZMUMPS_738 SUBROUTINE ZMUMPS_665(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt 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_665 SUBROUTINE ZMUMPS_666(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTRINSIC sqrt 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_666 SUBROUTINE ZMUMPS_671(D, DSZ, INDX, INDXSZ, VAL) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION VAL INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO RETURN END SUBROUTINE ZMUMPS_671 SUBROUTINE ZMUMPS_702(D, DSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = 1.0D0/D(IIND) ENDDO RETURN END SUBROUTINE ZMUMPS_702 SUBROUTINE ZMUMPS_670(D, DSZ, VAL) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION VAL INTEGER I DO I=1,DSZ D(I) = VAL ENDDO RETURN END SUBROUTINE ZMUMPS_670 SUBROUTINE ZMUMPS_650(TMPD, TMPSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER TMPSZ,INDXSZ DOUBLE PRECISION TMPD(TMPSZ) INTEGER INDX(INDXSZ) INTEGER I DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO RETURN END SUBROUTINE ZMUMPS_650 SUBROUTINE ZMUMPS_703(INV, INOUTV, LEN, DTYPE) IMPLICIT NONE INTEGER LEN INTEGER INV(2*LEN) INTEGER INOUTV(2*LEN) INTEGER DTYPE INTEGER I INTEGER DIN, DINOUT, PIN, PINOUT DO I=1,2*LEN-1,2 DIN = INV(I) PIN = INV(I+1) DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_703 SUBROUTINE ZMUMPS_668(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER IWSZ INTEGER IW(IWSZ) INTEGER IVAL INTEGER I DO I=1,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE ZMUMPS_668 SUBROUTINE ZMUMPS_704(MYID, NUMPROCS, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRKROW, IWRKCOL, IWSZR, IWSZC, COMM ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, M, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(M) INTEGER MYCOLINDICES(N) INTEGER INUMMYR, INUMMYC INTEGER IWSZR, IWSZC INTEGER IWRKROW(IWSZR) INTEGER IWRKCOL(IWSZC) INTEGER COMM INTEGER I, IR, IC, ITMP INUMMYR = 0 INUMMYC = 0 DO I=1,M IWRKROW(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRKROW(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRKROW(IR) .EQ. 0) THEN IWRKROW(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO ITMP = 1 DO I=1,M IF(IWRKROW(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO DO I=1,N IWRKCOL(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRKCOL(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRKCOL(IC) .EQ. 0) THEN IWRKCOL(IC)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDIF ENDDO ITMP = 1 DO I=1,N IF(IWRKCOL(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_704 SUBROUTINE ZMUMPS_672(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ, OSZ INTEGER ISNDRCVNUM, ISNDRCVVOL INTEGER OSNDRCVNUM, OSNDRCVVOL INTEGER COMM INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWRKSZ) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INCLUDE 'mpif.h' INTEGER I INTEGER IIND, IIND2, PIND INTEGER IERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO DO I=1,NZ_loc IIND = INDX(I) IIND2 = OINDX(I) 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 IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 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_672 SUBROUTINE ZMUMPS_674(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 MYID, NUMPROCS, NZ_loc, ISZ, ISNDVOL, OSNDVOL, OSZ INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) 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 INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR DO I=1,ISZ IWRK(I) = 0 ENDDO 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 DO I=1,NZ_loc IIND=INDX(I) IIND2 = OINDX(I) 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 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_674 SUBROUTINE ZMUMPS_657(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 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 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 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_657 SUBROUTINE ZMUMPS_656(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 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 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 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_656 SUBROUTINE ZMUMPS_655(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL ZMUMPS_703 INTEGER MYID, NUMPROCS, COMM INTEGER NZ_loc, ISZ, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWSZ) INCLUDE 'mpif.h' INTEGER I INTEGER OP, IERROR INTEGER IR, IC IF(NUMPROCS.NE.1) THEN CALL MPI_OP_CREATE(ZMUMPS_703, .TRUE., OP, IERROR) CALL ZMUMPS_668(IWRK, 4*ISZ, ISZ) DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_655 SUBROUTINE ZMUMPS_673(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ INTEGER ISNDRCVNUM, ISNDRCVVOL INTEGER OSNDRCVNUM, OSNDRCVVOL INTEGER COMM INTEGER INDX(NZ_loc), OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWRKSZ) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INCLUDE 'mpif.h' INTEGER I INTEGER IIND, IIND2, PIND INTEGER IERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO DO I=1,NZ_loc IIND = INDX(I) IIND2 = OINDX(I) 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 IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I) 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 CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 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_673 SUBROUTINE ZMUMPS_663(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER INUMMYR INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC INUMMYR = 0 DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 RETURN END SUBROUTINE ZMUMPS_663 INTEGER FUNCTION ZMUMPS_742(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_744 INTEGER ZMUMPS_744 INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = ZMUMPS_744(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) ZMUMPS_742 = GLORES RETURN END FUNCTION ZMUMPS_742 SUBROUTINE ZMUMPS_661(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, N INTEGER INUMMYR, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC, ITMP, MAXMN MAXMN = N DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_661 SUBROUTINE ZMUMPS_692(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, NZ_loc, ISZ, ISNDVOL, OSNDVOL INTEGER INDX(NZ_loc), OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) 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 INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR DO I=1,ISZ IWRK(I) = 0 ENDDO 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 DO I=1,NZ_loc IIND=INDX(I) IIND2 = OINDX(I) 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(I) 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 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_692 SUBROUTINE ZMUMPS_628(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_628 SUBROUTINE ZMUMPS_629 &(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_729( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE ZMUMPS_629 SUBROUTINE ZMUMPS_630(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_630 SUBROUTINE ZMUMPS_631(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_631 SUBROUTINE ZMUMPS_94(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE) 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) 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 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) RETURN 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_629(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_729(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_630(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_631(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_94" ENDIF IF (RBEGCONTIG > 0_8) GOTO 25 CALL ZMUMPS_629 & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL ZMUMPS_628(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL ZMUMPS_627(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_627(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_729(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL ZMUMPS_631(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_724(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_729( 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_94" 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 RETURN END SUBROUTINE ZMUMPS_94 SUBROUTINE ZMUMPS_632(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_729(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_632 SUBROUTINE ZMUMPS_627(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_627" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_627" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_627",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_627 SUBROUTINE ZMUMPS_700(BUFR,LBUFR, & LBUFR_BYTES, & root, N, IW, LIW, A, LA, & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, 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) 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_S(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 ), PTRAIW(N), PTRARW( N ) INTEGER INTARR(max(1,KEEP(14))) COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) INCLUDE 'mpif.h' INTEGER IERR 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_S( 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 ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_681(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL ZMUMPS_580(IERR) ENDIF CALL ZMUMPS_507( 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_500( & 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 ENDIF IF (KEEP(60) == 0) THEN CALL ZMUMPS_284( 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, 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_S(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST_S(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_700' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_38( 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 CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) 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_700' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL ZMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_38( 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_38( 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 CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) ENDIF RETURN END SUBROUTINE ZMUMPS_700 SUBROUTINE ZMUMPS_762(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_762 SUBROUTINE ZMUMPS_761(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_761 SUBROUTINE ZMUMPS_763(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_762(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_763 SUBROUTINE ZMUMPS_764( & 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_771 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_771, & .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_764 SUBROUTINE ZMUMPS_771(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE INTEGER, INTENT(IN) :: NEL, DATATYPE 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_762(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_771 SUBROUTINE ZMUMPS_765(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP COMPLEX(kind=8), intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE ZMUMPS_765 SUBROUTINE ZMUMPS_766(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER DETER=1.0D0/DETER NEXP=-NEXP RETURN END SUBROUTINE ZMUMPS_766 SUBROUTINE ZMUMPS_767(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_767 SUBROUTINE ZMUMPS_224(NFRONT,NASS,IBEGKJI, LPIV, TIPIV, & 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER IBEGKJI, LPIV INTEGER TIPIV(LPIV) INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW DOUBLE PRECISION UU, SEUIL 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(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U COMPLEX(kind=8) SWOP INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3_8 INTEGER(8) :: NFRONT8 INTEGER ILOC COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) DOUBLE PRECISION RZERO, RMAX, AMROW, ONE DOUBLE PRECISION PIVNUL COMPLEX(kind=8) FIXA, CSEUIL INTEGER NPIV,NASSW,IPIV INTEGER NPIVP1,JMAX,J3,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF INCLUDE 'mumps_headers.h' INTEGER ZMUMPS_IXAMAX INTRINSIC max DATA RZERO /0.0D0/ DATA ONE /1.0D0/ INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER XSIZE PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) NFRONT8=int(NFRONT,8) 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_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL ZMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ILOC = NPIVP1 - IBEGKJI + 1 TIPIV(ILOC) = ILOC NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_680( 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 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF (UU.GT.RZERO) GO TO 340 IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 340 AMROW = RZERO J1 = APOS J2 = APOS +int(- NPIV + NASS - 1,8) J3 = NASS -NPIV JMAX = ZMUMPS_IXAMAX(J3,A(J1),1) JJ = int(JMAX,8) + J1 - 1_8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = J2 + 1_8 J2 = APOS +int(- NPIV + NFRONT - KEEP(253)- 1,8) IF (J2.LT.J1) GO TO 370 DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF (RMAX.LE.PIVNUL) THEN KEEP(109) = KEEP(109)+1 ISW = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6+KEEP(IXSZ)+ & IW(IOLDPS+5+KEEP(IXSZ))+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 - KEEP(253) - 1,8) DO JJ=J1,J2 A(JJ)= ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF IF (abs(A(IDIAG)).GT.max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE.max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258).NE.0) THEN CALL ZMUMPS_762( 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_8 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3_8) A(J3_8) = SWOP J3_8 = J3_8 + 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) TIPIV(ILOC) = ILOC + JMAX - 1 J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,NASS 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 (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 WRITE(*,*) 'NIV2:Detected 0 pivot, INODE,NPIV=',INODE,NPIV GOTO 430 420 CONTINUE IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_680( 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_224 SUBROUTINE ZMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & IW, LIW, & IOLDPS, POSELT, A, LA, LDA_FS, & IBEGKJI, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEGKJI, 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) 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), & PTRARW(LPTRAR), PTRAIW(LPTRAR), & ND( KEEP(28) ), FRERE( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) 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(max(1,KEEP(13))) EXTERNAL ZMUMPS_329 INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES 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_294 ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEGKJI + 1 NCOL = LDA_FS - IBEGKJI + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEGKJI-1,8) + & int(IBEGKJI - 1,8) IF (IBEGKJI > 0) THEN CALL MUMPS_511( LDA_FS, IBEGKJI-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_511( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL ZMUMPS_190(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTBL)) ) THEN PDEST = IOLDPS + 6 + KEEP(IXSZ) IERR = -1 IF ( NPIV .NE. 0 ) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF DO WHILE (IERR .EQ.-1) CALL ZMUMPS_65( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTBL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP(50), NB_BLOC_FAC, & COMM, IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF (MESSAGE_RECEIVED) POSELT = PTRAST(STEP(INODE)) 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 CALL MUMPS_731( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 500 RETURN END SUBROUTINE ZMUMPS_294 SUBROUTINE ZMUMPS_273( 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, & 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) 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_330 EXTERNAL MUMPS_330 IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_330(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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_273', & ' 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_507(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE ZMUMPS_273 SUBROUTINE ZMUMPS_363(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_275 INTEGER MUMPS_275 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_170,MUMPS_167 LOGICAL MUMPS_170,MUMPS_167 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_363",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_363' 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_363' 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_363' 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_363' 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_363' 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_363' 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_462(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_363' 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_170(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_170(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_170(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_170(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_462(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_462(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_462(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(*,*)'Probleme dans reorder!!!!' 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_462(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_511(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_167(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_170( & 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_511(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_170( & PROCNODE(STEP(INODE)),SLAVEF)))THEN CALL ZMUMPS_462(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_363 SUBROUTINE ZMUMPS_364(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_283,MUMPS_275 LOGICAL MUMPS_283 INTEGER MUMPS_275 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 INDICE(SLAVEF),ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_170,MUMPS_167 LOGICAL MUMPS_170,MUMPS_167 DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK 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 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_363",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)) RETURN 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_363' 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_363' 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_363' 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_363' 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_462(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_363' 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_167(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_283(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_167(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_511(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_167(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_283(PROCNODE(STEP(INODE)),SLAVEF))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_275(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_275(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_167(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_275(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_170(PROCNODE(STEP(INODE)), & SLAVEF))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_283(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) 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_364 RECURSIVE SUBROUTINE ZMUMPS_462(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_462(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL ZMUMPS_462(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_462 mumps-4.10.0.dfsg/src/mumps_tags.h0000644000175300017530000001111211562233011017206 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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 ) INTEGER COLLECT_NZ, COLLECT_IRN, COLLECT_JCN PARAMETER( COLLECT_NZ = 35, * COLLECT_IRN = 36, * COLLECT_JCN = 37 ) INTEGER RACINE, * NOEUD, * TERREUR, * MAITRE_DESC_BANDE, * MAITRE2, * BLOC_FACTO, * CONTRIB_TYPE2, * MAPLIG, * FACTOR PARAMETER ( RACINE = 2, * NOEUD = 3, * MAITRE_DESC_BANDE = 4, * MAITRE2 = 5, * BLOC_FACTO = 6, * CONTRIB_TYPE2 = 7, * MAPLIG = 8, * FACTOR = 9, * TERREUR = 99 ) 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 ) INTEGER RACINE_SOLVE, * ContVec, * Master2Slave, * GatherSol, * ScatterRhsI, * ScatterRhsR PARAMETER( RACINE_SOLVE = 10, * ContVec = 11, * Master2Slave = 12, * GatherSol = 13, * ScatterRhsI = 54, * ScatterRhsR = 55) INTEGER FEUILLE, * BACKSLV_UPDATERHS, * BACKSLV_MASTER2SLAVE PARAMETER( FEUILLE = 21, * BACKSLV_UPDATERHS = 22, * BACKSLV_MASTER2SLAVE = 23 ) INTEGER SYMMETRIZE PARAMETER ( SYMMETRIZE = 24 ) 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 ) INTEGER UPDATE_LOAD PARAMETER ( UPDATE_LOAD = 27 ) INTEGER DEFIC_TAG PARAMETER( DEFIC_TAG = 28 ) INTEGER TAG_SCHUR PARAMETER( TAG_SCHUR = 38 ) INTEGER TAG_DUMMY PARAMETER( TAG_DUMMY = 39 ) INTEGER ZERO_PIV PARAMETER( ZERO_PIV = 40 ) mumps-4.10.0.dfsg/src/dmumps_ooc.F0000644000175300017530000035553311562233066017166 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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 #if defined (NEW_PREF_SCHEME) INTEGER,SAVE :: MAX_PREF_SIZE #endif & ,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_575,DMUMPS_576, & DMUMPS_577, & DMUMPS_578, & DMUMPS_579, & DMUMPS_582, & DMUMPS_583,DMUMPS_584, & DMUMPS_585,DMUMPS_586 INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC DMUMPS_688, & DMUMPS_690 PRIVATE DMUMPS_695, & DMUMPS_697 CONTAINS SUBROUTINE DMUMPS_711( 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_711 FUNCTION DMUMPS_579(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL DMUMPS_579 DMUMPS_579=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION DMUMPS_579 SUBROUTINE DMUMPS_590(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE DMUMPS_590 SUBROUTINE DMUMPS_575(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*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 CALL DMUMPS_588(id,IERR) 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_796(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_711( 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_669(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_589(TMP_DIR(1), & id%OOC_TMPDIR, TMPDIR_MAX_LENGTH, DIM_DIR ) CALL DMUMPS_589(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,kind=4)+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_575 SUBROUTINE DMUMPS_576(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_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_678 & (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_707(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_707(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_689(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_576 SUBROUTINE DMUMPS_577(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE DOUBLE PRECISION DEST INTEGER ASYNC LOGICAL IO_C #if defined(OLD_READ) INTEGER REQUEST #endif 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. #if ! defined(OLD_READ) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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 #else OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) 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 ) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_READ_OOC' ENDIF RETURN 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 #endif 555 CONTINUE IF(.NOT.DMUMPS_727())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_728() ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_577 SUBROUTINE DMUMPS_591(IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL DMUMPS_675(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE DMUMPS_591 SUBROUTINE DMUMPS_592(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_659() 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_613(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_592 SUBROUTINE DMUMPS_588(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*1 TMP_NAME(350) IERR=0 K=1 IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,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 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_588 SUBROUTINE DMUMPS_587(id,IERR) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC), TARGET :: id INTEGER IERR IERR=0 CALL DMUMPS_588(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_587 SUBROUTINE DMUMPS_586(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_275 INTEGER MUMPS_275 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_VADDR) ENDIF CALL MUMPS_796(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_614(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_586' 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_711( 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_586' id%INFO(1) = -11 CALL MUMPS_731(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_586' 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_586' 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_586' 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_586' 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_275( & 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_275( & 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 #if defined (NEW_PREF_SCHEME) MAX_PREF_SIZE=(1024*1024*2)/8 #endif RETURN END SUBROUTINE DMUMPS_586 SUBROUTINE DMUMPS_585(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_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL DMUMPS_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_585 SUBROUTINE DMUMPS_594(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_603(ZONE) IERR=0 CALL DMUMPS_611(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE DMUMPS_594 SUBROUTINE DMUMPS_595(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_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_597(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL DMUMPS_597(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_596(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE DMUMPS_595 SUBROUTINE DMUMPS_596(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_330,MUMPS_275 INTEGER MUMPS_330,MUMPS_275 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_330(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_275( & 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_330(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_275( & 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_596 SUBROUTINE DMUMPS_597(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_596(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_597',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_597',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_597 ',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_597 SUBROUTINE DMUMPS_598(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_598', & 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_600(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_608(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_601(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_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL DMUMPS_603(ZONE) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_598 FUNCTION DMUMPS_726(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_726 IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN DMUMPS_726=OOC_NODE_PERMUTED ELSE DMUMPS_726=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.DMUMPS_727())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_728() 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_596(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL DMUMPS_599(INODE,PTRFAC,NSTEPS) IF(.NOT.DMUMPS_727())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_728() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN DMUMPS_726=OOC_NODE_PERMUTED ELSE DMUMPS_726=OOC_NODE_NOT_PERMUTED ENDIF ELSE DMUMPS_726=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION DMUMPS_726 SUBROUTINE DMUMPS_682(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_682 SUBROUTINE DMUMPS_599(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_610(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_609(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE DMUMPS_599 SUBROUTINE DMUMPS_600(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_600 SUBROUTINE DMUMPS_601(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE DMUMPS_601 SUBROUTINE DMUMPS_603(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_603 SUBROUTINE DMUMPS_578(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_608(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_606(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(DMUMPS_579(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL DMUMPS_604(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_606(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL DMUMPS_605(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL DMUMPS_605(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL DMUMPS_604(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_606(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL DMUMPS_608(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_606(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_578 SUBROUTINE DMUMPS_604(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_604', & 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_596( & 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_604' 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_604' 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_604 SUBROUTINE DMUMPS_605(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_605', & 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_596( & 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_605' 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_605' 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_596( & 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_605' 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_605 SUBROUTINE DMUMPS_606(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_606 SUBROUTINE DMUMPS_607(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_607' 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_607 SUBROUTINE DMUMPS_608(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_608',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_596( & 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_596( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' DMUMPS_608',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_596( & 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_608 SUBROUTINE DMUMPS_609(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_609' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_610(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_609 SUBROUTINE DMUMPS_610(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_610 FUNCTION DMUMPS_727() IMPLICIT NONE LOGICAL DMUMPS_727 DMUMPS_727=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN DMUMPS_727=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN DMUMPS_727=.TRUE. ENDIF ENDIF RETURN END FUNCTION DMUMPS_727 SUBROUTINE DMUMPS_611(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_727())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_727())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL DMUMPS_728() 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_727())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL DMUMPS_728() 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_604(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_605(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_605(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_604(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_608(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL DMUMPS_602(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_595(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE DMUMPS_611 SUBROUTINE DMUMPS_602(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_727())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_602',FLAG CALL MUMPS_ABORT() ENDIF CALL DMUMPS_728() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 #if defined (NEW_PREF_SCHEME) IF(MAX_SIZE.GT.MAX_PREF_SIZE)THEN MAX_SIZE=MIN(MAX(MAX_PREF_SIZE, & SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE)), & MAX_SIZE) ENDIF #endif 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_602 SUBROUTINE DMUMPS_582(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_582 SUBROUTINE DMUMPS_612(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_600(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).OR.(J.NE.SPECIAL_ROOT_NODE) & .OR.(ZONE.NE.NB_Z))THEN CALL DMUMPS_599(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.ALREADY_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_599(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_608(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_608 =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_612 SUBROUTINE DMUMPS_583(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_808 EXTERNAL MUMPS_808 IERR = 0 OOC_FCT_TYPE=MUMPS_808("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_612(PTRFAC,NSTEPS,A,LA) ELSE CALL DMUMPS_683(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL DMUMPS_585(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE DMUMPS_583 SUBROUTINE DMUMPS_584(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_808 EXTERNAL MUMPS_808 IERR=0 OOC_FCT_TYPE=MUMPS_808("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_612(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT) THEN CALL DMUMPS_598 ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN CALL DMUMPS_600(IROOT, & ZONE,PTRFAC,NSTEPS) IF(IROOT.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL DMUMPS_608(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & DMUMPS_608', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL DMUMPS_594(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL DMUMPS_683(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL DMUMPS_585(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE DMUMPS_584 SUBROUTINE DMUMPS_613(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*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_613' 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_613' 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_613 SUBROUTINE DMUMPS_614(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC), TARGET :: id CHARACTER*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_614' 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_614 SUBROUTINE DMUMPS_589(DEST,SRC,NB,NB_EFF) IMPLICIT NONE INTEGER NB, NB_EFF CHARACTER(LEN=NB) SRC CHARACTER*1 DEST(NB) INTEGER I DO I=1,NB_EFF DEST(I)=SRC(I:I) ENDDO END SUBROUTINE DMUMPS_589 SUBROUTINE DMUMPS_580(IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL DMUMPS_707(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE DMUMPS_580 SUBROUTINE DMUMPS_681(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_707(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE DMUMPS_681 SUBROUTINE DMUMPS_683(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_683 SUBROUTINE DMUMPS_688 & ( 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_695( 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_695( 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_688 SUBROUTINE DMUMPS_695( 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_690(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = DMUMPS_725 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = DMUMPS_725 & (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_695 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_695,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_695', & 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_695 ', & ' 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_697( 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_695 ', & ' 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_695" 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_695 SUBROUTINE DMUMPS_697( & 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_653( 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_697 INTEGER(8) FUNCTION DMUMPS_725 & (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_725 = TOTSIZE RETURN END FUNCTION DMUMPS_725 INTEGER FUNCTION DMUMPS_690( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER DMUMPS_748 DMUMPS_690=DMUMPS_748( & HBUF_SIZE, NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION DMUMPS_690 SUBROUTINE DMUMPS_728() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.DMUMPS_727())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_728 SUBROUTINE DMUMPS_809(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_809 END MODULE DMUMPS_OOC mumps-4.10.0.dfsg/src/zmumps_part1.F0000644000175300017530000064152611562233070017456 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE ZMUMPS( id ) USE ZMUMPS_OOC USE ZMUMPS_STRUC_DEF IMPLICIT NONE C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), INTERFACE SUBROUTINE ZMUMPS_758 &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE ZMUMPS_758 SUBROUTINE ZMUMPS_26( id ) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id END SUBROUTINE ZMUMPS_26 SUBROUTINE ZMUMPS_142( id ) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id END SUBROUTINE ZMUMPS_142 SUBROUTINE ZMUMPS_301( id ) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id END SUBROUTINE ZMUMPS_301 SUBROUTINE ZMUMPS_349(id, LP) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE ZMUMPS_349 END INTERFACE INCLUDE 'mpif.h' INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE (ZMUMPS_STRUC) :: id INTEGER JOBMIN, JOBMAX, OLDJOB INTEGER I, J, MP, LP, MPG, KEEP235SAVE, KEEP242SAVE, & KEEP243SAVE LOGICAL LANAL, LFACTO, LSOLVE, PROK, FLAG, PROKG LOGICAL NOERRORBEFOREPERM LOGICAL UNS_PERM_DONE INTEGER COMM_SAVE INTEGER JOB, N, NZ, NELT INTEGER, PARAMETER :: ICNTL18DIST_MIN = 1 INTEGER, PARAMETER :: ICNTL18DIST_MAX = 3 INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV NOERRORBEFOREPERM = .FALSE. UNS_PERM_DONE = .FALSE. JOB = id%JOB N = id%N NZ = id%NZ NELT = id%NELT id%INFO(1) = 0 id%INFO(2) = 0 IF ( JOB .NE. -1 ) THEN LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.3)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (PROKG) THEN IF (id%ICNTL(5) .NE. 1) THEN WRITE(MPG,'(A,I4,I12,I15)') & 'Entering ZMUMPS driver with JOB, N, NZ =', JOB,N,NZ ELSE WRITE(MPG,'(A,I4,I12,I15)') & 'Entering ZMUMPS driver with JOB, N, NELT =', JOB,N & ,NELT ENDIF ENDIF ELSE MPG = 0 PROK = .FALSE. PROKG = .FALSE. LP = 6 MP = 6 END IF CALL MPI_INITIALIZED( FLAG, IERR ) IF ( .NOT. FLAG ) THEN WRITE(LP,990) 990 FORMAT(' Error in ZMUMPS initialization: MPI is not running.') id%INFO(1) = -23 id%INFO(2) = 0 GOTO 500 END IF COMM_SAVE = id%COMM CALL MPI_COMM_DUP( COMM_SAVE, id%COMM, IERR ) CALL MPI_ALLREDUCE(JOB,JOBMIN,1,MPI_INTEGER,MPI_MAX, & id%COMM,IERR) CALL MPI_ALLREDUCE(JOB,JOBMAX,1,MPI_INTEGER,MPI_MIN, & id%COMM,IERR) IF ( JOBMIN .NE. JOBMAX ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF ( JOB .EQ. -1 ) THEN id%INFO(1)=0 id%INFO(2)=0 IF ( id%KEEP(40) .EQ. 1 - 456789 .OR. & id%KEEP(40) .EQ. 2 - 456789 .OR. & id%KEEP(40) .EQ. 3 -456789 ) THEN IF ( id%N > 0 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ENDIF ENDIF CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR) CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) THEN IF (id%KEEP(201).GT.0) THEN CALL ZMUMPS_587(id, IERR) ENDIF GOTO 499 ENDIF CALL ZMUMPS_163( id ) GOTO 500 END IF IF ( JOB .EQ. -2 ) THEN id%KEEP(40)= -2 - 456789 CALL ZMUMPS_136( id ) GOTO 500 END IF IF ((JOB.LT.1).OR.(JOB.GT.6)) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF (id%MYID.EQ.MASTER) THEN IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN IF ((N.LE.0).OR.((N+N+N)/3.NE.N)) THEN id%INFO(1) = -16 id%INFO(2) = N END IF IF (id%ICNTL(5).NE.1) THEN IF (NZ.LE.0) THEN id%INFO(1) = -2 id%INFO(2) = NZ END IF ELSE IF (NELT.LE.0) THEN id%INFO(1) = -24 id%INFO(2) = NELT END IF ENDIF END IF IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF END IF CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 LANAL = .FALSE. LFACTO = .FALSE. LSOLVE = .FALSE. IF ((JOB.EQ.1).OR.(JOB.EQ.4).OR. & (JOB.EQ.6)) LANAL = .TRUE. IF ((JOB.EQ.2).OR.(JOB.EQ.4).OR. & (JOB.EQ.5).OR.(JOB.EQ.6)) LFACTO = .TRUE. IF ((JOB.EQ.3).OR.(JOB.EQ.5).OR. & (JOB.EQ.6)) LSOLVE = .TRUE. IF (MP.GT.0) CALL ZMUMPS_349(id, MP) OLDJOB = id%KEEP( 40 ) + 456789 IF ( LANAL ) THEN 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 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 IF ( OLDJOB .LT. 1 .and. .NOT. LANAL ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF IF ( LSOLVE ) THEN IF ( OLDJOB .LT. 2 .AND. .NOT. LFACTO ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF #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 id%INFO(1)=-13 id%INFO(2)=id%N IF (id%ICNTL(1) .GT. 0 .AND. id%ICNTL(4) .GE.1) THEN WRITE(id%ICNTL(2),99993) END IF GOTO 510 ENDIF DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I END DO DO I = 1, id%NZ J = id%JCN(I) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I)=UNS_PERM_INV(J) END DO DEALLOCATE(UNS_PERM_INV) END IF END IF #endif CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 IF (LANAL) THEN id%KEEP(40)=-1 -456789 IF (id%MYID.EQ.MASTER) THEN id%INFOG(7) = -9999 id%INFOG(23) = 0 id%INFOG(24) = 1 IF (associated(id%IS1)) DEALLOCATE(id%IS1) IF ( id%ICNTL(5) .NE. 1 ) THEN 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 = 11 * N ELSE id%MAXIS1 = 10 * N END IF ELSE id%MAXIS1 = 6 * N + 2 * NELT + 2 ENDIF ALLOCATE( id%IS1(id%MAXIS1), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%MAXIS1 IF ( LP .GT.0 ) & WRITE(LP,*) 'Problem in allocating work array for analysis.' GO TO 100 END IF 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 ( LP .GT. 0 ) THEN WRITE(LP,*) 'Problem in allocating work array PROCNODE' END IF GOTO 100 END IF id%PROCNODE(1:id%N) = 0 IF ( id%ICNTL(5) .EQ. 1 ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP,*) 'Problem in allocating work array ELTPROC' END IF GOTO 100 END IF END IF IF ( id%ICNTL(5) .NE. 1 ) THEN id%NA_ELT=0 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 ELSE IF ( size( id%IRN ) < id%NZ ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE IF ( size( id%JCN ) < id%NZ ) THEN id%INFO(1) = -22 id%INFO(2) = 2 END IF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF (LP.GT.0) WRITE(LP,*) & '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 id%NA_ELT = 0 IF ( id%KEEP(50) .EQ. 0 ) THEN DO I = 1,NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) J = (J * J) id%NA_ELT = id%NA_ELT + J ENDDO ELSE DO I = 1,NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) J = (J * (J+1))/2 id%NA_ELT = id%NA_ELT + J ENDDO ENDIF ENDIF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF (LP.GT.0) WRITE(LP,*) & 'Error in analysis: ELTPTR/ELTVAR badly allocated.' END IF ENDIF 100 CONTINUE END IF CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(52) = id%ICNTL(8) IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 CALL ZMUMPS_26( id ) 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 IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF IF (LFACTO) THEN id%KEEP(40) = 1 - 456789 IF ( id%MYID .EQ. MASTER ) THEN IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN id%SCHUR=>id%SCHUR_CINTERFACE & (1:id%SIZE_SCHUR*id%SIZE_SCHUR) 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 IF ( id%KEEP(55) .EQ. 0 ) THEN IF ( id%KEEP(54).eq.0 ) THEN IF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE IF ( size( id%A ) < id%NZ ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF END IF ELSE IF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE IF ( size( id%A_ELT ) < id%NA_ELT ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF CALL MUMPS_633(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) CALL ZMUMPS_635(N,id%KEEP(1),id%ICNTL(1),MPG) 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.77) THEN IF (id%KEEP(50).EQ.1) THEN id%KEEP(52) = 0 ELSE 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 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 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 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 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 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 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 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(N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 END IF 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 ( LP .GT. 0 ) & WRITE(LP,*) 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL ZMUMPS_758 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) CALL ZMUMPS_807(id) CALL ZMUMPS_769(id) ENDIF 200 CONTINUE END IF CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( id%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN id%SCHUR=>id%SCHUR_CINTERFACE & (1:id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) ENDIF 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 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 CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL ZMUMPS_142(id) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) 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 IF ( id%INFO(1) .LT. 0 ) GO TO 499 id%KEEP(40) = 2 - 456789 END IF IF (LSOLVE) THEN id%KEEP(40) = 2 -456789 IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 ENDIF CALL ZMUMPS_301(id) IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 id%KEEP(40) = 3 -456789 ENDIF IF (MP.GT.0) CALL ZMUMPS_349(id, MP) GOTO 500 499 PROK = ((id%ICNTL(1).GT.0).AND. & (id%ICNTL(4).GE.1)) IF (PROK) WRITE (id%ICNTL(1),99995) id%INFO(1) IF (PROK) WRITE (id%ICNTL(1),99994) id%INFO(2) 500 CONTINUE #if ! defined(LARGEMATRICES) IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN IF (id%JOB .NE. 3 .OR. UNS_PERM_DONE) THEN DO I = 1, id%NZ J=id%JCN(I) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I)=id%UNS_PERM(J) END DO END IF END IF #endif 510 CONTINUE CALL ZMUMPS_300(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) CALL MPI_BCAST( id%RINFOG(1), 40, MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I12)') ' On return from ZMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I12)') ' On return from ZMUMPS, INFOG(2)=', & id%INFOG(2) END IF CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE RETURN 99995 FORMAT (' ** ERROR RETURN ** FROM ZMUMPS INFO(1)=', I3) 99994 FORMAT (' ** INFO(2)=', I10) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE ZMUMPS SUBROUTINE ZMUMPS_300( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INFO(40), INFOG(40), COMM, MYID INTEGER TMP1(2),TMP(2) INTEGER ROOT, IERR INTEGER MASTER PARAMETER (MASTER=0) IF ( INFO(1) .ge. 0 .and. INFO(2) .ge. 0 ) THEN INFOG(1) = INFO(1) INFOG(2) = INFO(2) ELSE INFOG(1) = INFO(1) 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 CALL MPI_BCAST(INFOG(3), 38, MPI_INTEGER, MASTER, COMM, IERR ) RETURN END SUBROUTINE ZMUMPS_300 SUBROUTINE ZMUMPS_349(id, LP) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LT.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) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SHUR) =',I10) END SUBROUTINE ZMUMPS_349 SUBROUTINE ZMUMPS_350(id, LP) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LT.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_350 SUBROUTINE ZMUMPS_758 & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE 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_758 SUBROUTINE ZMUMPS_807(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE 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_807 SUBROUTINE ZMUMPS_769(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE 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 RETURN END SUBROUTINE ZMUMPS_769 SUBROUTINE ZMUMPS_24( 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 ), & 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_330, MUMPS_275, MUMPS_810 EXTERNAL MUMPS_330, MUMPS_275, MUMPS_810 INTEGER ISTEP, I, IPTRI, IPTRR, NCOL, NROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) KEEP(14) = 0 KEEP(13) = 0 DO I = 1, N ISTEP=abs(STEP(I)) ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_810 ( 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. 1.OR.ITYPE.EQ.2) .AND. & IRANK .EQ. MYID ) & .OR. & ( T4_MASTER_CONCERNED ) & ) THEN KEEP( 14 ) = KEEP( 14 ) + 3 + PTRAIW( I ) + PTRARW( I ) KEEP( 13 ) = KEEP( 13 ) + 1 + PTRAIW( I ) + PTRARW( I ) ELSE IF ( ITYPE .EQ. 3 ) THEN ELSE IF ( ITYPE .EQ. 2 .AND. I_AM_CAND_LOC ) THEN PTRARW( I ) = 0 KEEP(14) = KEEP(14) + 3 + PTRAIW( I ) + PTRARW( I ) KEEP(13) = KEEP(13) + 1 + PTRAIW( I ) + PTRARW( I ) END IF END DO IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( KEEP(14) > 0 ) THEN ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = KEEP(14) 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 IPTRR = 1 DO I = 1, N ISTEP = abs(STEP(I)) ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_810 ( 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 = PTRAIW( I ) NROW = PTRARW( I ) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + NCOL + NROW + 3 IPTRR = IPTRR + NCOL + NROW + 1 ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NCOL = 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 + NCOL + NROW + 3 IPTRR = IPTRR + NCOL + NROW + 1 ELSE PTRAIW(I) = 0 PTRARW(I) = 0 END IF END DO IF ( IPTRI - 1 .NE. KEEP(14) ) THEN WRITE(*,*) 'Error 1 in anal_arrowheads', & ' IPTRI - 1, KEEP(14)=', IPTRI - 1, KEEP(14) CALL MUMPS_ABORT() END IF IF ( IPTRR - 1 .NE. KEEP(13) ) THEN WRITE(*,*) 'Error 2 in anal_arrowheads' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE ZMUMPS_24 SUBROUTINE ZMUMPS_148(N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & LP, COMM, root, KEEP, KEEP8, FILS, RG2L, & INTARR, DBLARR, PTRAIW, PTRARW, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES ) IMPLICIT NONE INCLUDE 'zmumps_root.h' INTEGER N,NZ, COMM, NBRECORDS 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) :: LA INTEGER PTRAIW( N ), PTRARW( N ), FRERE_STEPS( KEEP(28) ) INTEGER STEP(N) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX(kind=8) A( LA ), DBLARR(max(1,KEEP(13))) INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE :: BUFR INTEGER MUMPS_275, MUMPS_330, numroc, & MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, numroc, & MUMPS_810 COMPLEX(kind=8) VAL INTEGER IOLD,JOLD,INEW,JNEW,ISEND,JSEND,DEST,I,K,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 I1, IA, JARR, ILOCROOT, JLOCROOT INTEGER IS1, ISHIFT, IIW, IS, IAS INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 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_330( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE = MUMPS_275( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_810( PROCNODE_STEPS(ISTEP), & SLAVEF ) I_AM_CAND_LOC = .FALSE. 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 = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL END IF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 ) & .AND. IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF (MUMPS_275( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) == MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL ZMUMPS_310( 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 DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) & CALL ZMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN CALL ZMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN CALL ZMUMPS_34( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( DEST .GT. 0 ) THEN CALL ZMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) IF ( T4MASTER.GT.0 ) THEN CALL ZMUMPS_34( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN CALL ZMUMPS_34( 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_18( & 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_148 SUBROUTINE ZMUMPS_34(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_34 SUBROUTINE ZMUMPS_18( & 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_18 RECURSIVE SUBROUTINE ZMUMPS_310( 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_310(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL ZMUMPS_310(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE ZMUMPS_310 SUBROUTINE ZMUMPS_145( 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, LDBLARR, LINTARR, & COMM INTEGER INTARR(LINTARR) INTEGER 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) 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, IA, I1, I, allocok INTEGER IS, IS1, ISHIFT, IIW, IAS INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 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 STATUS( MPI_STATUS_SIZE ) INTEGER IERR 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 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 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_330( 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 IA = PTRARW(IARR) DBLARR(IA) = DBLARR(IA) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL ENDIF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) & .AND. IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_275( 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_310( 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_145 SUBROUTINE ZMUMPS_266( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & TNBPROCFILS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, ITLOC, RHS_MUMPS, & IFLAG, IERROR ) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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 COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_RECU, NFRONT INTEGER LREQ INTEGER(8) :: LREQCB DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' INODE = BUFR( 1 ) NBPROCFILS = BUFR( 2 ) NROW = BUFR( 3 ) NCOL = BUFR( 4 ) NASS = BUFR( 5 ) NFRONT = BUFR( 6 ) NSLAVES_RECU = BUFR( 7 ) 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_190(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_22(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP,KEEP8, 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 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( 8 + NSLAVES_RECU : 7 + NSLAVES_RECU + NROW + NCOL ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_RECU.GT.0) & IW( IWPOSCB + 7+XTRA_SLAVES_UNSYM+KEEP(IXSZ): & IWPOSCB+6+KEEP(IXSZ)+NSLAVES_RECU ) = & BUFR( 8: 7 + NSLAVES_RECU ) ELSE IW( IWPOSCB + 7+KEEP(IXSZ) ) = 0 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( 8: 7 + NSLAVES_RECU ) END IF TNBPROCFILS(STEP( INODE )) = NBPROCFILS RETURN END SUBROUTINE ZMUMPS_266 SUBROUTINE ZMUMPS_163( id ) USE ZMUMPS_STRUC_DEF USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC) id INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) PAR_loc=id%PAR SYM_loc=id%SYM CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( PAR_loc .eq. 0 ) THEN 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 CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF CALL ZMUMPS_20( 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%WRITE_PROBLEM="NAME_NOT_INITIALIZED" CALL MUMPS_SET_VERSION( id%VERSION_NUMBER ) id%OOC_TMPDIR="NAME_NOT_INITIALIZED" id%OOC_PREFIX="NAME_NOT_INITIALIZED" id%NRHS = 1 id%LRHS = 0 id%LREDRHS = 0 CALL ZMUMPS_61( id%KEEP( 34 ), id%KEEP(35) ) NULLIFY(id%BUFR) id%MAXIS1 = 0 id%INST_Number = -1 id%N = 0; id%NZ = 0 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0 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) 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%POIDS) 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%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) 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%CB_SON_SIZE) 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) id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 id%SCHUR_NLOC = 0 id%SCHUR_LLD = 0 NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) CALL ZMUMPS_637(id) NULLIFY(id%MEM_DIST) NULLIFY(id%SUP_PROC) id%Deficiency = 0 id%root%LPIV = -1 id%root%yes = .FALSE. id%root%gridinit_done = .FALSE. 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_163 SUBROUTINE ZMUMPS_252( COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & & 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 & ) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR 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) INTEGER IFLAG,IERROR,INODE,MAXFRW, & IWPOS, IWPOSCB, COMP INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 COMPLEX(kind=8) A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)) INTEGER NSTK_S(KEEP(28)),PROCNODE_STEPS(KEEP(28)) INTEGER IPOOL( LPOOL ) INTEGER BUFR( LBUFR ) INTEGER IDUMMY(1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(N), PTRAIW(N), ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 INTARR(max(1,KEEP(14))) COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) INTEGER MUMPS_330 EXTERNAL MUMPS_330 INTEGER LP, HS, HF 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) :: SIZFR INTEGER SIZFI, NCB INTEGER J1,J2 INTEGER NCOLS, NROWS, LDA_SON INTEGER(8) :: JJ2, ICT13 #if defined(ALLOW_NON_INIT) INTEGER(8) :: NUMROWS, JJ3, JJ8, APOS_ini #endif INTEGER NELIM,JJ,JJ1,J3, & IBROT,IORG INTEGER JPOS,ICT11 INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4 INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER AINPUT 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 INCLUDE 'mumps_headers.h' INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_167 LOGICAL MUMPS_167 LOGICAL SSARBR LOGICAL COMPRESSCB INTEGER(8) :: LCB DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_170 LOGICAL MUMPS_170 COMPRESSCB =.FALSE. NELT = 1 LPTRAR = N NFS4FATHER = -1 IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (LEVEL.NE.1) THEN write(6,*) 'Error1 in mpi51f_niv1 ' CALL MUMPS_ABORT() ENDIF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_167(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) ENDDO 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 NASS = NASS + IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG LREQ_OOC = 0 IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_684( 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF 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_330(PROCNODE_STEPS(STEP(ISON)),SLAVEF) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_729(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. IF (KEEP(50).EQ.0 .AND. KEEP(234) .EQ. 0) THEN CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, & NFRONT_EFF, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, & PROCNODE_STEPS, SLAVEF ) ELSE CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF) IF (IFLAG.LT.0) GOTO 300 ENDIF IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_170(PROCNODE_STEPS(STEP(INODE)), & SLAVEF))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL ZMUMPS_190(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 Write(*,*) ' ERROR 1 during ass_niv1', NFRONT, NFRONT_EFF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL ZMUMPS_691(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 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 GOTO 280 ELSE CALL ZMUMPS_94 & (N, KEEP(28), IW, LIW, A, LA, LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER,KEEP(216),LRLUS,KEEP(IXSZ)) COMP = COMP + 1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL ZMUMPS_471(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLU) #if ! defined(ALLOW_NON_INIT) 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) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO ELSE IF (ETATASS.EQ.1) THEN APOS_ini = POSELT DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8,int(NASS1-1,8)) APOS = APOS_ini + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO ELSE APOS_ini = POSELT NUMROWS = min(NFRONT8, (IPTRLU-APOS_ini) / NFRONT8 ) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = APOS_ini + JJ8 * NFRONT8 A(APOS:APOS + JJ8) = ZERO ENDDO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = APOS_ini + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST_S(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 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)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) 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.LE.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS J1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1) THEN J2 = J1 + LSTK - 1 SIZFR = int(LSTK,8)*int(LSTK,8) IF (COMPRESSCB) SIZFR = (int(LSTK,8)*int(LSTK+1,8))/2_8 ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR = int(NELIM,8) * int(LSTK,8) ELSE SIZFR = int(NELIM,8) * int(NELIM,8) END IF J2 = J1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) OPASSW = OPASSW + dble(SIZFR) 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 + SIZFR - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (J2.GE.J1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC) RISK_OF_SAME_POS = IACHK + SIZFR - 1_8 .EQ. POSFAC - 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. & ((J2-J1).GT.300) DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * int(NFRONT,8) IACHK = IACHK_ini + int(JJ-J1,8)*int(LSTK,8) IF (RISK_OF_SAME_POS) THEN IF (JJ.EQ.J2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(IW(J1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(JJ>J1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) IF ( IACHK+int(JJ1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(JJ1 - 1,8)) A(IACHK + int(JJ1 -1,8)) = ZERO ENDIF ENDDO ELSE DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 A(JJ2) = A(IACHK + int(JJ1 - 1,8)) A(IACHK + int(JJ1 -1,8)) = ZERO ENDDO ENDIF ELSE DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 1,8)) ENDDO ENDIF 170 CONTINUE END IF ELSE IF (LEVEL1) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR ELSE LCB = int(LDA_SON,8)* int(J2-J1+1,8) ENDIF CALL ZMUMPS_178(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), J2 - J1 + 1, NELIM, ETATASS, & COMPRESSCB, (ISON.EQ.ISON_IN_PLACE) & ) 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 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 J3 = J3 - 1 DO JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = 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_152(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_49( & 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_210( 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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .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_71( & 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_329( & 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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 JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) IJROW = INTARR(J1) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) Cduplicates --> CVD$ DEPCHK DO 240 JJ = J1, J2 APOS2 = ICT12 + int(INTARR(JJ),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + 1 240 CONTINUE IF (J3 .LE. J4) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = J4 - J3 + 1 Cduplicates--> CVD$ DEPCHK CduplicatesCVD$ NODEPCHK DO 250 JJ = 1, NBCOL APOS3 = ICT13 + int(INTARR(J3 + JJ - 1) - 1,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT + JJ - 1) 250 CONTINUE ENDIF IF (KEEP(50).EQ.0) THEN DO JJ=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ELSE DO JJ=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+JJ-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE GOTO 500 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_252' ENDIF GOTO 490 280 CONTINUE IFLAG = -9 CALL MUMPS_731(LAELL_REQ8 - LRLUS, IERROR) IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING ZMUMPS_252' ENDIF 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 DURING ZMUMPS_252' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING ZMUMPS_252' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING ZMUMPS_252' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 490 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_252 SUBROUTINE ZMUMPS_253(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM , MEM_DISTRIB) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER IFLAG,IERROR,INODE,MAXFRW, & LPOOL, LEAF, IWPOS, IWPOSCB, COMP INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC COMPLEX(kind=8) A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, SLAVEF, 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 IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(N), PTRAIW(N), ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 INTARR(max(1,KEEP(14))) COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) INTEGER LP, HS, HF, HF_OLD,NCBSON, NSLAVES_OLD, & NBSPLIT INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER,I INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER NCB INTEGER J1,J2,J3,MP INTEGER(8) :: JJ8, LAPOS2, JJ2, JJ3 INTEGER NELIM,JJ,JJ1,NPIVS,NCOLS,NROWS, & IBROT,IORG INTEGER LDAFS, LDA_SON INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4, NUMORG_SPLIT INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 INTEGER AINPUT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, ISLAVE, PDEST INTEGER PDEST1(1) INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6 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_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 COMPLEX(kind=8) ZERO DOUBLE PRECISION RZERO PARAMETER(RZERO = 0.0D0 ) PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER NELT, LPTRAR, NCBSON_MAX logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER (8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok, & NCB_SPLIT, SIZE_LIST_SPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER NBPANELS_L, NBPANELS_U MP = ICNTL(2) 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_330(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) .EQ. 1) THEN NCBSON_MAX = max & ( & IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)), NCBSON_MAX & ) 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 IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) SIZE_TMP_SLAVES_LIST = CAND( SLAVEF+1, INIV2 ) ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), & SLAVEF) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) 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 265 ENDIF CALL ZMUMPS_791 ( & 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_472( 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_790 ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) TMP_SLAVES_LIST (1:SIZE_TMP_SLAVES_LIST) & = CAND (1:SIZE_TMP_SLAVES_LIST, INIV2) CALL ZMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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_472( 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_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. IF (KEEP(50).EQ.0 .AND. KEEP(234).EQ.0) THEN CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, & NFRONT_EFF, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & PROCNODE_STEPS, SLAVEF ) ELSE ISON_IN_PLACE = -9999 CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF) IF (IFLAG.LT.0) GOTO 250 ENDIF 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 plitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF 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 WRITE(6,*) ' Internal error 2 in fac_ass due', & ' to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF CALL MUMPS_ABORT() ELSE CALL ZMUMPS_472( 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 JJ=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+JJ)=IW(IOLDPS+HF_OLD+JJ) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO JJ=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+JJ) = IW(IOLDPS+HF_OLD+JJ) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE Write(*,*) MYID,': ERROR 2 during ass_niv2, INODE=', INODE, & ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL ZMUMPS_691(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST_S(STEP(INODE)) = IOLDPS 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+KEEP(IXSZ)) = NFRONT 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_461(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_533(SLAVEF,CAND(SLAVEF+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_533(SLAVEF,SLAVEF-1, & 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 CALL ZMUMPS_471(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLU) POSEL1 = POSELT - int(LDAFS,8) #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, int(LDAFS-1,8) A(APOS:APOS+JJ8) = ZERO APOS = APOS + int(LDAFS,8) END DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN A(APOS:APOS+int(LDAFS,8)-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 + 1+KEEP(IXSZ)) 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.LE.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 + 2+KEEP(IXSZ)) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) J1 = ISTCHK + HS + NROWS + NPIVS J2 = J1 + 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 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * int(LDAFS,8) DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 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 CALL ZMUMPS_178( A, LA, & POSELT, LDAFS, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), NELIM, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) DO 260 IORG = 1, NUMORG JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) IJROW = INTARR(J1) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO CduplicatesCVD$ NODEPCHK DO 240 JJ = J1, J2 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT))) ENDIF ELSE IF (INTARR(JJ).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) ENDIF ENDIF AINPUT = AINPUT + 1 240 CONTINUE IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = cmplx(MAXARR,kind=kind(A)) ENDIF IF (J3 .GT. J4) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = J4 - J3 + 1 CduplicatesCVD$ NODEPCHK CduplicatesCVD$ NODEPCHK DO JJ = 1, NBCOL JJ3 = ICT13 + int(INTARR(J3 + JJ - 1),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT + JJ - 1) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO JJ = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & 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_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & IW(PDEST), NFRONT, COMM, IERR) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL ZMUMPS_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & IW(PDEST), NFRONT, COMM, IERR) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST_S(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 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.LE.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) THEN IF(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 ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) IF (PDEST1(1).EQ.MYID) THEN CALL ZMUMPS_211( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON))+HS+NROWS+NPIVS+NELIM CALL ZMUMPS_71( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST_S(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_329( 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, ND, FRERE, LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_49( & 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_210( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .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_71( & INODE, NFRONT,NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST_S(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_329( 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & ZMUMPS_253' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 GOTO 490 265 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING ZMUMPS_253' ENDIF IFLAG = -13 IERROR = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_253' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING ZMUMPS_253' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8-LRLUS, IERROR) 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_253' ENDIF IFLAG = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) 490 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_253 SUBROUTINE ZMUMPS_39(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_39 SUBROUTINE ZMUMPS_539 & (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), PTRARW(N), PTRAIW(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) COMPLEX(kind=8) A(LA), & DBLARR(max(1,KEEP(13))) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSELT, ICT12, APOS INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS,JJ, & IN,AINPUT,JK,J1,J2,IJROW, ILOC INTEGER :: K1RHS, K2RHS, JFirstRHS 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 A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = & ZERO 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) AINPUT = PTRARW(IN) JK = PTRAIW(IN) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) IJROW = -ITLOC(INTARR(J1)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ= J1,J2 ILOC = ITLOC(INTARR(JJ)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT) ENDIF AINPUT = AINPUT + 1 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO 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_539 SUBROUTINE ZMUMPS_531 & (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_531 SUBROUTINE ZMUMPS_40(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 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 write(6,*) ' .. exit for col =', J 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_40 SUBROUTINE ZMUMPS_178( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED, IS_INPLACE & ) 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, IS_INPLACE COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE, OMP_FLAG INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IF ( IS_INPLACE ) THEN 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 ENDIF 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN OMP_FLAG = (NROWS-NELIM).GE.300 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) .AND. .NOT. IS_INPLACE) 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) + & A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 END DO ENDIF END 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_178 SUBROUTINE ZMUMPS_530(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_530 SUBROUTINE ZMUMPS_619( & 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(abs(A(JJ2)) .LT. VALSON(JJ1)) & A(JJ2) = cmplx(VALSON(JJ1),kind=kind(A)) ENDDO RETURN END SUBROUTINE ZMUMPS_619 RECURSIVE SUBROUTINE ZMUMPS_264( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE ZMUMPS_OOC USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 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 PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) 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 ) INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL INTEGER(8) :: POSBLOCFACTO 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 MUMPS_275 EXTERNAL MUMPS_275 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 ) LAELL = int(NPIV,8) * int(NCOL,8) IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_731(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_264" ENDIF GOTO 700 END IF CALL ZMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731( 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_264" 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)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL ZMUMPS_471(.FALSE., .FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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)) 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 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 LPOS2 = POSELT + int(NPIV1,8) CALL ztrsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), NCOL, A(LPOS2), NCOL1) LPOS1 = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) ENDIF 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 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL ZMUMPS_688( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( NPIV .GT. 0 ) THEN CALL zgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,A(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 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. LASTBL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) ' ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) IWPOS = IWPOS - NPIV 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_190( 1, .FALSE., FLOP1, KEEP,KEEP8 ) IF (LASTBL) THEN CALL ZMUMPS_759( & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE ZMUMPS_264 SUBROUTINE ZMUMPS_699( 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_S, 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, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE ZMUMPS_LOAD USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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_S( KEEP(28) ) INTEGER NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX(kind=8) DBLARR( max( 1,KEEP(13)) ) 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 STATUS( MPI_STATUS_SIZE ) INTEGER MUMPS_275, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_810 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 BLOCKING, SET_IRECV, MESSAGE_RECEIVED, IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT 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_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_810(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) DO WHILE ( PTRIST( STEP(INODE) ) .EQ. 0 ) MASTER = MUMPS_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MASTER, MAITRE_DESC_BANDE, & STATUS, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF (IFLAG.LT.0) RETURN END DO 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_731( LREQA - LRLUS, IERROR ) CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF CALL ZMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..process_contrib' WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 CALL MUMPS_731( LREQA - LRLUS, IERROR ) CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF END IF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) 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))-1 ENDIF IF ( KEEP(55) .eq. 0 ) THEN CALL ZMUMPS_539 & (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_123( & 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_40(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_531 & (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_39(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST_S, 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_617(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL ZMUMPS_619(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - 1 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK .LT. IWPOSCB IF (SAME_PROC) THEN CALL ZMUMPS_530(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, 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_152(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN CALL ZMUMPS_507( 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_500( & 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 POSFAC = POSFAC - LREQA CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) RETURN END SUBROUTINE ZMUMPS_699 SUBROUTINE ZMUMPS_143( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, UU, NOFFW, & NPVW, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS ) USE ZMUMPS_OOC IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, 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(30) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK INTEGER NASS, NEL1, NPIVB, NPIVE, NBOLKJ, NBTLKJ DOUBLE PRECISION UUTEMP INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INCLUDE 'mumps_headers.h' EXTERNAL MUMPS_330, ZMUMPS_221, ZMUMPS_233, & ZMUMPS_229, & ZMUMPS_225, ZMUMPS_232, ZMUMPS_231, & ZMUMPS_220, & ZMUMPS_228, ZMUMPS_236 INTEGER MUMPS_330 LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC 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 IBEG_BLOCK=1 NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IF (KEEP(201).EQ.1) THEN CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_BOTH_LU 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 50 CONTINUE CALL ZMUMPS_221(NFRONT,NASS,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) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF GOTO 80 ENDIF IF (INOPV.EQ.2) THEN CALL ZMUMPS_233(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP(IXSZ)) GOTO 50 ENDIF NPVW = NPVW + 1 IF (NASS.LE.1) THEN CALL ZMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 GO TO 500 ENDIF CALL ZMUMPS_225(IBEG_BLOCK,NFRONT, NASS, N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 50 IF (KEEP(201).EQ.1) THEN MonBloc%LastPiv= IW(IOLDPS+1+KEEP(IXSZ)) STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_U LAST_CALL = .FALSE. CALL ZMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC ENDIF IF (IFINB.EQ.(-1)) GOTO 80 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV CALL ZMUMPS_232(A,LA, & NFRONT,NPIV,NASS,POSELT,NBTLKJ) GO TO 50 80 CONTINUE NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IF (NPIV.LE.0) GO TO 110 NEL1 = NFRONT - NASS IF (NEL1.LE.0) GO TO 110 IF (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_BOTH_LU MonBloc%LastPiv= NPIV CALL ZMUMPS_642(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_231(A,LA,NFRONT, NPIV,NASS,POSELT) ENDIF 110 CONTINUE IF (MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) & .EQ.1) THEN NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 120 CALL ZMUMPS_220(NFRONT,NASS,N,INODE,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) IF (INOPV.NE.1) THEN NPVW = NPVW + 1 CALL ZMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVB = IBEG_BLOCK NPIVE = NPIV - NPIVB NEL1 = NFRONT - NASS IF ((NPIVE.LE.0).OR.(NEL1.EQ.0)) GO TO 500 CALL ZMUMPS_236(A,LA,NPIVB, & NFRONT,NPIV,NASS,POSELT) ENDIF 500 CONTINUE IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) TYPEFile = TYPEF_BOTH_LU LAST_CALL = .TRUE. CALL ZMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC CALL ZMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE ZMUMPS_143 RECURSIVE SUBROUTINE ZMUMPS_322( & 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) 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) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) 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_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 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 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( max(1,KEEP(14)) ) COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) INTEGER INIV2, ISHIFT, IBEG INTEGER MUMPS_275 EXTERNAL MUMPS_275 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 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) CHARACTER(LEN=35)::SUBNAME MP = ICNTL(2) LP = ICNTL(1) SUBNAME="??????" CALL ZMUMPS_467(COMM_LOAD, KEEP) 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_269( MYID,KEEP,KEEP8, & 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_269" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL ZMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL ZMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_500( & 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_266( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, NBPROCFILS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, ITLOC, RHS_MUMPS, & IFLAG, IERROR ) SUBNAME="ZMUMPS_266" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL ZMUMPS_268(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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & KEEP,KEEP8, ND, FILS, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="ZMUMPS_268" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO ) THEN CALL ZMUMPS_264( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL ZMUMPS_263( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL ZMUMPS_274( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL ZMUMPS_699( 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_S, 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, IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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).AND.(KEEP(48).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_210( 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_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL ZMUMPS_700( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF) SUBNAME="ZMUMPS_700" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(IROOT)), & SLAVEF ) IF ( PTLUST_S( STEP(IROOT)) .EQ. 0 ) THEN CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL ZMUMPS_270( TMP( 1 ), TMP( 2 ), & 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, ND ) SUBNAME="ZMUMPS_270" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL ZMUMPS_700( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF ) SUBNAME="ZMUMPS_700" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL ZMUMPS_271( 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GO TO 100 IF (MYID.NE.MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF)) THEN IF (KEEP(50).EQ.0) THEN IF (IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)) = S_ROOT2SON_CALLED ELSE CALL ZMUMPS_626( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ELSE IF (IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)) = S_ROOT2SON_CALLED ELSE CALL ZMUMPS_626( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL ZMUMPS_270( 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_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, 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_273( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, KEEP,KEEP8, & COMM, COMM_LOAD, FILS, ND) SUBNAME="ZMUMPS_273" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_322" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine ZMUMPS_322.',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_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE ZMUMPS_322 RECURSIVE SUBROUTINE ZMUMPS_280( & COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) 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) 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(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(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 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 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( max(1,KEEP(14)) ) COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) 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_44( MYID, SLAVEF, COMM ) RETURN ENDIF CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL ZMUMPS_322( & 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) RETURN END SUBROUTINE ZMUMPS_280 RECURSIVE SUBROUTINE ZMUMPS_329( & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED ) 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) 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(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 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 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( max(1,KEEP(14)) ) COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) 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_467(COMM_LOAD, KEEP) 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 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_329' CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF IF ( FLAG ) THEN 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_322( 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_280( COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_280( COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_329 SUBROUTINE ZMUMPS_255( INFO1, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE ZMUMPS_COMM_BUFFER 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 STATUS( MPI_STATUS_SIZE ) LOGICAL NO_ACTIVE_IRECV INTEGER MSGSOU_LOC, MSGTAG_LOC 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) ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL ZMUMPS_62 & (DUMMY, DEST, TAG_DUMMY, COMM, 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 RETURN END SUBROUTINE ZMUMPS_255 SUBROUTINE ZMUMPS_180( & INFO1, BUFR, LBUFR, LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, MP ) USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER COMM_NODES, COMM_LOAD, SLAVEF, INFO1, MP INTEGER STATUS( MPI_STATUS_SIZE ) LOGICAL FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS INTEGER MSGSOU_LOC, MSGTAG_LOC, COMM_EFF INTEGER IERR INTEGER IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS IF (SLAVEF.EQ.1) RETURN BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. 10 CONTINUE FLAG = .TRUE. DO WHILE ( FLAG ) COMM_EFF = COMM_NODES CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, & COMM_NODES, FLAG, STATUS, IERR) IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_LOAD CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM_LOAD, FLAG, STATUS, IERR) END IF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_RECV( BUFR, LBUFR_BYTES, & MPI_PACKED, MSGSOU_LOC, & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) ENDIF END DO IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN RETURN ENDIF CALL ZMUMPS_469(BUFFERS_EMPTY) IF ( BUFFERS_EMPTY ) THEN IBUF_EMPTY = 0 ELSE IBUF_EMPTY = 1 ENDIF CALL MPI_ALLREDUCE(IBUF_EMPTY, & IBUF_EMPTY_ON_ALL_PROCS, & 1, MPI_INTEGER, MPI_MAX, & COMM_NODES, IERR) IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. ELSE BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. ENDIF GOTO 10 END SUBROUTINE ZMUMPS_180 INTEGER FUNCTION ZMUMPS_748 & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) K227_LOC = abs(K227) IF (K50.EQ.2) THEN K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) ELSE 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_748 = EFFECTIVE_SIZE RETURN END FUNCTION ZMUMPS_748 SUBROUTINE ZMUMPS_698( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) COMPLEX(kind=8) THE_PANEL(NBROW, NBCOL) INTEGER I, IPERM DO I = 1, LPIV 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_698 SUBROUTINE ZMUMPS_667(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) INTEGER I_NBPANELS, I_NASS I_NASS = IPOS I_NBPANELS = I_NASS + 1 NBPANELS = IW(I_NBPANELS) I_PIVPTR = I_NBPANELS + 1 I_PIV = I_PIVPTR + NBPANELS IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) NBPANELS = IW(I_NBPANELS) I_PIVPTR = I_NBPANELS + 1 I_PIV = I_PIVPTR + NBPANELS ENDIF RETURN END SUBROUTINE ZMUMPS_667 SUBROUTINE ZMUMPS_691(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) INTEGER IPOS_U IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: ZMUMPS_691 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_691 SUBROUTINE ZMUMPS_644 ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE ZMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE IF (KEEP(50).EQ.1) RETURN IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE CALL ZMUMPS_667(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 CALL ZMUMPS_667(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 IF (FREESPACE) THEN IW(IBEGOOC) = -7777 IW(IOLDPS+XXI) = IBEGOOC - IOLDPS + 1 IWPOS = IBEGOOC+1 ENDIF RETURN END SUBROUTINE ZMUMPS_644 SUBROUTINE ZMUMPS_684(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE ZMUMPS_OOC IMPLICIT NONE INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF NBPANELS_L = (NASS / ZMUMPS_690(NBROW_L))+1 LREQ = 1 & + 1 & + NASS & + NBPANELS_L IF (K50.eq.0) THEN NBPANELS_U = (NASS / ZMUMPS_690(NBCOL_U) ) +1 LREQ = LREQ + 1 & + NASS & + NBPANELS_U ENDIF RETURN END SUBROUTINE ZMUMPS_684 SUBROUTINE ZMUMPS_755 & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_755 mumps-4.10.0.dfsg/src/mumps_size.h0000644000175300017530000000456011562233011017233 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #ifndef MUMPS_SIZE_H #define MUMPS_SIZE_H #include "mumps_common.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-4.10.0.dfsg/src/cmumps_part5.F0000644000175300017530000102212511562233067017426 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE CMUMPS_26(id) USE CMUMPS_LOAD USE MUMPS_STATIC_MAPPING USE CMUMPS_STRUC_DEF USE TOOLS_COMMON USE CMUMPS_PARALLEL_ANALYSIS IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) TYPE(CMUMPS_STRUC), TARGET :: id INTEGER LIW, IKEEP, FILS, FRERE, PTRAR, NFSIZ INTEGER NE, NA INTEGER I, allocok INTEGER MAXIS1_CHECK 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 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 INTEGER(8) K13TMP8, K14TMP8 REAL PEAK INTEGER, ALLOCATABLE, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR 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_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 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 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 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 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (PROK) WRITE( MP, 220 ) IF (PROKG.AND.(MPG .NE. MP)) WRITE( MPG, 220 ) id%VERSION_NUMBER 220 FORMAT( /' CMUMPS ',A ) 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 ) CALL CMUMPS_647(id) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ) ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN CALL MPI_ALLREDUCE( id%NZ_loc, id%NZ, 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR ) ELSE CALL MPI_BCAST( id%NZ, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) END IF ELSE CALL MPI_BCAST( id%NA_ELT, 1, MPI_INTEGER, 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_427( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO) CALL CMUMPS_658(id) IF (KEEP(244) .EQ. 1) THEN IF ( KEEP(54) .eq. 3 ) THEN CALL CMUMPS_664(id) END IF IF ( id%MYID .eq. MASTER ) THEN 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 IF (.not.associated(id%A)) THEN IF (KEEP(23).GT.2) KEEP(23) = 1 ENDIF CALL CMUMPS_203(id%N, id%NZ, KEEP(23), id%IS1(1), id, & ICNTL(1), INFO(1)) IF (INFO(1) .LT. 0) THEN KEEP(23) = 0 GOTO 10 END IF END IF IF (KEEP(55) .EQ. 0) THEN IF ( KEEP(256) .EQ. 1 ) THEN LIW = 2 * id%NZ + 3 * id%N + 2 ELSE LIW = 2 * id%NZ + 3 * id%N + 2 ENDIF IF (LIW.LT.3*id%N) LIW = 3*id%N ELSE #if defined(metis) || defined(parmetis) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN LIW = id%N + id%N + 1 ELSE LIW = id%N + id%N + id%N+3 + id%N+1 ENDIF ENDIF IF (LIW.LT.3*id%N) LIW = 3*id%N 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 PTRAR = FRERE + id%N IF (KEEP(55) .EQ. 0) THEN NFSIZ = PTRAR + 4 * id%N MAXIS1_CHECK = NFSIZ + id%N - 1 ELSE NFSIZ = PTRAR + 2 * (NELT + 1) MAXIS1_CHECK = NFSIZ + id%N -1 ENDIF IF ( id%MAXIS1 .LT. MAXIS1_CHECK ) THEN IF (LP.GE.0) THEN WRITE(LP,*) '***********************************' WRITE(LP,*) 'MAXIS1 and MAXIS1_CHECK are different !!' WRITE(LP,*) 'MAXIS1, MAXIS1_CHECK=',id%MAXIS1, & MAXIS1_CHECK WRITE(LP,*) 'This might cause problems ...' WRITE(LP,*) '***********************************' ENDIF END IF IF ( KEEP(256) .EQ. 1 ) THEN DO I = 1, id%N id%IS1( IKEEP + I - 1 ) = id%PERM_IN( I ) END DO END IF INFOG(1) = 0 INFOG(2) = 0 INFOG(8) = -1 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 IF (KEEP(55) .EQ. 0) THEN CALL CMUMPS_195(id%N, id%NZ, id%IRN(1), id%JCN(1), & LIW, id%IS1(IKEEP), & id%IS1(PTRAR), 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 KEEP(23) = -KEEP(23) IF (.NOT. associated(id%A)) KEEP(23) = 1 GOTO 1234 ENDIF INFOG(7) = KEEP(256) ELSE allocate( IWtemp ( 3*id%N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*id%N IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IWtemp' END IF GOTO 10 ENDIF allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL CMUMPS_128(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW, & id%IS1(IKEEP), & IWtemp(1), 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%ELTPROC(1), id%NSLAVES, & XNODEL(1), NODEL(1)) DEALLOCATE(IWtemp) INFOG(7)=KEEP(256) ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN deallocate( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) ENDIF INFO(1)=INFOG(1) INFO(2)=INFOG(2) KEEP(28) = INFOG(6) IF ( INFO(1) .LT. 0 ) THEN GO TO 10 ENDIF ENDIF ELSE IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N PTRAR = FRERE + id%N NFSIZ = PTRAR + 4 * id%N IF(id%MYID .EQ. MASTER) THEN WORK1PTR => id%IS1(IKEEP : IKEEP + 3*id%N-1) WORK2PTR => id%IS1(PTRAR : PTRAR + 4*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) ELSE ALLOCATE(WORK1PTR(3*id%N)) ALLOCATE(WORK2PTR(4*id%N)) END IF CALL CMUMPS_715(id, & WORK1PTR, & WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR) IF(id%MYID .EQ. 0) THEN NULLIFY(WORK1PTR, WORK2PTR, NFSIZPTR) NULLIFY(FILSPTR, FREREPTR) ELSE DEALLOCATE(WORK1PTR, WORK2PTR) END IF KEEP(28) = INFOG(6) END IF 10 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN IF(id%MYID .EQ. MASTER) THEN CALL MUMPS_633(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL CMUMPS_348(id%N, id%IS1(FILS), id%IS1(FRERE), & id%IS1(IKEEP+2*id%N), id%IS1(IKEEP+id%N)) IF (id%NSLAVES .EQ. 1) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN id%KEEP(20)=0 id%KEEP(38)=0 ENDIF id%KEEP(56)=0 id%PROCNODE = 0 IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN CALL CMUMPS_564(id%KEEP(38), id%PROCNODE(1), & 1+2*id%NSLAVES, id%IS1(FILS),id%N) ENDIF ELSE PEAK = real(id%INFOG(5))*real(id%INFOG(5)) + & real(id%KEEP(2))*real(id%KEEP(2)) SSARBR => id%IS1(IKEEP:IKEEP+id%N-1) CALL CMUMPS_537(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 in MUMPS_369' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL CMUMPS_348(id%N, id%IS1(FILS), & id%IS1(FRERE), id%IS1(IKEEP+2*id%N), & id%IS1(IKEEP+id%N)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ) ELSE LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_733(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_733(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_733(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN IF(id%MYID .EQ. MASTER) THEN CALL CMUMPS_153( & 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 id%PTRAR(id%NELT+I+1)=id%ELTPTR(I) ENDDO deallocate(XNODEL) deallocate(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER, & 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 IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN CALL CMUMPS_120(id%N, NELT, id%ELTPROC(1),id%NSLAVES, & id%PROCNODE(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LP .GT. 0 ) 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_330(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_26", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_393 & (PAR2_NODES,id%CANDIDATES,IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF CALL MUMPS_494() 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF 12 CONTINUE KEEP(84) = ICNTL(27) END IF CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MUMPS_749( id%KEEP8(21), MASTER, & id%MYID, id%COMM, IERR) CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MUMPS_733(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_733(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_733(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_733(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_733(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_733(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_733(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_733(id%SYM_PERM, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 IF (KEEP(55) .EQ. 0) THEN LPTRAR = id%N+id%N CALL MUMPS_733(id%PTRAR, LPTRAR, id%INFO, LP, FORCE=.TRUE., & STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF ( associated( id%UNS_PERM ) ) deallocate(id%UNS_PERM) IF ( id%MYID == MASTER .AND. id%KEEP(23) .NE. 0 ) THEN allocate(id%UNS_PERM(id%N),stat=allocok) IF ( allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = id%N IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'id%UNS_PERM' END IF GOTO 94 ENDIF DO I=1,id%N id%UNS_PERM(I) = id%IS1(I) END DO ENDIF 94 CONTINUE CALL MUMPS_276( 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 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_733(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 id%NA(1) = NBLEAF id%NA(2) = NBROOT 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF IF ( id%MYID .EQ. MASTER ) THEN ISTEP = 0 DO I = 1, id%N IF ( id%IS1(FRERE+I-1) .ne. id%N + 1 ) THEN 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 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_26' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in CMUMPS_26' CALL MUMPS_ABORT() ENDIF 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 DO I = 1, id%N IF ( id%STEP(I) .LE. 0) CYCLE IF (id%IS1(FRERE+I-1) .eq. 0) THEN id%DAD_STEPS(id%STEP(I)) = 0 ENDIF IFS = id%IS1(FILS+I-1) DO WHILE ( IFS .GT. 0 ) IFS= id%IS1(FILS + IFS -1) END DO IFS = -IFS DO WHILE (IFS.GT.0) id%DAD_STEPS(id%STEP(IFS)) = I IFS = id%IS1(FRERE+IFS-1) ENDDO END DO deallocate(id%PROCNODE) NULLIFY(id%PROCNODE) deallocate(id%IS1) NULLIFY(id%IS1) CALL CMUMPS_363(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(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 SIZE_TEMP_MEM = id%NBSA ELSE 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 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 ( LP .GT. 0 ) 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_364(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 CALL CMUMPS_181(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) ) ENDIF 80 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN 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(55) .EQ. 0) THEN CALL CMUMPS_746(id, id%PTRAR(1)) IF(id%MYID .EQ. MASTER) THEN IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN DEALLOCATE( id%IRN ) DEALLOCATE( id%JCN ) END IF END IF ENDIF 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_276( 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 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 ( LP .GT. 0 ) 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 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(id%STEP(INN)) = INIV2 END DO CALL CMUMPS_649( id%NSLAVES, & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF #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 ( LP .GT. 0 ) 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_275( & id%PROCNODE_STEPS(id%STEP(PAR2_NODES(INIV2))), & id%NSLAVES) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO #endif 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 allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LP .GT. 0 ) 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 IF (NB_NIV2.GT.0) deallocate (PAR2_NODES) 321 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN 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 PTRAR = FRERE + id%N IF (KEEP(55) .EQ. 0) THEN IF ( id%MYID.EQ.MASTER ) THEN NFSIZ = PTRAR + 4 * id%N ELSE NFSIZ = PTRAR + 2 * id%N ENDIF ELSE NFSIZ = PTRAR + 2 * (NELT + 1) END IF IF ( KEEP(38) .NE. 0 ) THEN CALL CMUMPS_164( 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 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 ( LP > 0 .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 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF ( I_AM_SLAVE ) THEN IF (KEEP(55) .EQ. 0) THEN CALL CMUMPS_24( 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_25( 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 IF ( I_AM_SLAVE ) THEN 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 id%SCHUR_MLOC=LOCAL_M id%SCHUR_NLOC=LOCAL_N 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_246( id%MYID_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), & KEEP8(14), & 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), & id%I_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%MAX_SURF_MASTER = KEEP8(15) KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 2* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) INFO( 19 ) = KEEP(225) + 2* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /100_8 +1_8) CALL MUMPS_736 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) 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 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 ) KEEP(44) = max(KEEP(44), MIN_BUF_SIZE) KEEP(43) = max(KEEP(43), MIN_BUF_SIZE) IF ( MP .GT. 0 ) THEN WRITE(MP,'(A,I10) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I10) ') & ' INFO(3), est. complex space to store factors:', & KEEP8(11) WRITE(MP,'(A,I10) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I10) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I10) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I10) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I10) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF ELSE 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 CALL MUMPS_736( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_736( 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_646( KEEP8(11), KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735( KEEP8(111), INFOG(3) ) CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_REAL, MPI_SUM, & id%COMM, IERR) CALL MUMPS_735( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_735( KEEP8(13), INFO(8) ) CALL MUMPS_735( KEEP8(17), INFO(20) ) CALL MUMPS_735( KEEP8(9), INFO(24) ) INFOG( 4 ) = KEEP( 126 ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_735( KEEP8(109), INFOG(20) ) CALL CMUMPS_100(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1)) OOC_STAT = KEEP(201) IF (KEEP(201) .NE. -1) OOC_STAT=0 PERLU_ON = .FALSE. CALL CMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(2) = TOTAL_BYTES PERLU_ON = .TRUE. CALL CMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' Estimated space in MBYTES for IC factorization :', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES CALL MUMPS_243( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of proc needing largest memory in IC facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Estimated corresponding MBYTES for IC facto :', & id%INFOG(16) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,(id%INFOG(17)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,id%INFOG(17)/id%NSLAVES END IF WRITE(MPG,'(A,I10) ') & ' ** TOTAL space in MBYTES for IC factorization :' & ,id%INFOG(17) END IF 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. CALL CMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(3) = TOTAL_BYTES PERLU_ON = .TRUE. CALL CMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) id%INFO(17) = TOTAL_MBYTES CALL MUMPS_243( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of proc needing largest memory for OOC facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Estimated corresponding MBYTES for OOC facto :', & id%INFOG(26) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,(id%INFOG(27)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,id%INFOG(27)/id%NSLAVES END IF WRITE(MPG,'(A,I10) ') & ' ** TOTAL space in MBYTES for OOC factorization :' & ,id%INFOG(27) END IF IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) & deallocate( id%MAPPING) allocate( id%MAPPING(id%NZ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NZ IF ( LP .GT. 0 ) 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF CALL CMUMPS_83( & id%N, id%MAPPING(1), & id%NZ, 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 150 FORMAT( & /' ** FAILURE DURING CMUMPS_26, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE CMUMPS_26 SUBROUTINE CMUMPS_537(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_369(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & ) RETURN END SUBROUTINE CMUMPS_537 SUBROUTINE CMUMPS_564(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_564 SUBROUTINE CMUMPS_647(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (id%MYID.eq.MASTER) THEN id%KEEP(256) = id%ICNTL(7) id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 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 id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN 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 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 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 WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' id%KEEP(60)=0 END IF 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 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 IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF id%KEEP(244) = id%ICNTL(28) id%KEEP(245) = id%ICNTL(29) #if ! defined(parmetis) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP,'("ParMETIS not available.")') WRITE(LP,'("Aborting.")') RETURN END IF END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP,'("PT-SCOTCH not available.")') WRITE(LP,'("Aborting.")') RETURN END IF END IF #endif IF((id%KEEP(244) .GT. 2) .OR. & (id%KEEP(244) .LT. 0)) id%KEEP(244)=0 IF(id%KEEP(244) .EQ. 0) THEN id%KEEP(244) = 1 ELSE IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') RETURN END IF 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 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) = 0 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 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 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 IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF 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 id%INFO(1) = -22 id%INFO(2) = 8 RETURN IF (MPG.GT.0) 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 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 id%KEEP(23) = id%ICNTL(6) IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 7 IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not compatible with LLT factorization' END IF ENDIF id%KEEP(95) = 1 END IF IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (MPG.GT.0) 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 (MPG.GT.0) 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. MPG.GT.0) 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 (MPG.GT.0) 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 IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed for element matrix' END IF id%KEEP(23) = 0 ENDIF IF (MPG.GT.0 .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 IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') RETURN END IF END IF IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF IF (id%ICNTL(39).NE.1 .and. id%ICNTL(39).NE.2) THEN id%KEEP(106)=1 ELSE id%KEEP(106)=id%ICNTL(39) ENDIF IF(id%KEEP(50) .EQ. 2) THEN IF( .NOT. associated(id%A) ) THEN 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 IF (PROK) WRITE(MP,*) & 'WARNING: CMUMPS_203 constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) 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 IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE 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 id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF id%KEEP(53)=0 IF(id%KEEP(86).EQ.1)THEN 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 END IF RETURN END SUBROUTINE CMUMPS_647 SUBROUTINE CMUMPS_664(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE(CMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER :: MASTER, IERR, INDX, NRECV INTEGER :: STATUS( MPI_STATUS_SIZE ) INTEGER :: LP, MP, MPG, I LOGICAL :: PROK, PROKG PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN id%NZ_loc = 0 END IF IF ( id%MYID .eq. MASTER ) THEN allocate( REQPTR( id%NPROCS, 3 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 3 * id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'REQPTR' END IF GOTO 13 END IF allocate( id%IRN( id%NZ ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NZ IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IRN' END IF GOTO 13 END IF allocate( id%JCN( id%NZ ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NZ IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'JCN' END IF GOTO 13 END IF END IF 13 CONTINUE CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN IF ( id%MYID .EQ. MASTER ) THEN DO I = 1, id%NPROCS - 1 CALL MPI_RECV( REQPTR( I+1, 1 ), 1, & MPI_INTEGER, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) END DO IF ( id%KEEP(46) .eq. 0 ) THEN REQPTR( 1, 1 ) = 1 ELSE REQPTR( 1, 1 ) = id%NZ_loc + 1 END IF DO I = 2, id%NPROCS REQPTR( I, 1 ) = REQPTR( I, 1 ) + REQPTR( I-1, 1 ) END DO ELSE CALL MPI_SEND( id%NZ_loc, 1, MPI_INTEGER, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN NRECV = 0 DO I = 1, id%NPROCS - 1 IF ( REQPTR( I + 1, 1 ) - REQPTR( I, 1 ) .NE. 0 ) THEN NRECV = NRECV + 2 CALL MPI_IRECV( id%IRN( REQPTR( I, 1 ) ), & REQPTR( I + 1, 1 ) - REQPTR( I, 1 ), & MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I, 2), IERR ) CALL MPI_IRECV( id%JCN( REQPTR( I, 1 ) ), & REQPTR( I + 1, 1 ) - REQPTR( I, 1 ), & MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I, 3), IERR ) ELSE REQPTR(I, 2) = MPI_REQUEST_NULL REQPTR(I, 3) = MPI_REQUEST_NULL END IF END DO ELSE IF ( id%NZ_loc .NE. 0 ) THEN CALL MPI_SEND( id%IRN_loc(1), id%NZ_loc, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(1), id%NZ_loc, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END IF END IF IF ( id%MYID .eq. MASTER ) THEN IF ( id%NZ_loc .NE. 0 ) THEN DO I=1,id%NZ_loc id%IRN(I) = id%IRN_loc(I) id%JCN(I) = id%JCN_loc(I) ENDDO END IF REQPTR( id%NPROCS, 2 ) = MPI_REQUEST_NULL REQPTR( id%NPROCS, 3 ) = MPI_REQUEST_NULL DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * id%NPROCS, REQPTR( 1, 2 ), INDX, STATUS, IERR ) END DO deallocate( REQPTR ) END IF RETURN 150 FORMAT( &/' ** FAILURE DURING CMUMPS_664, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE CMUMPS_664 SUBROUTINE CMUMPS_658(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(CMUMPS_STRUC) :: id 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) IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (id%MYID.EQ.MASTER .AND. .NOT. IS_DISTRIBUTED) THEN IF (id%WRITE_PROBLEM(1:20) .NE. "NAME_NOT_INITIALIZED")THEN OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL CMUMPS_166( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL ) CLOSE(IUNIT) ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN 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) IF (MM_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(MM_IDSTR,'(I7)') id%MYID_NODES OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(MM_IDSTR))) CALL CMUMPS_166(id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL ) CLOSE(IUNIT) ENDIF ENDIF 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_179(IUNIT, id) CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE CMUMPS_658 SUBROUTINE CMUMPS_166 & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL ) USE CMUMPS_STRUC_DEF IMPLICIT NONE LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL INTEGER, intent(in) :: IUNIT TYPE(CMUMPS_STRUC), intent(in) :: id CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER :: I IF (IS_ELEMENTAL) THEN RETURN ENDIF IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED) THEN IF (associated(id%A)) 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, id%NZ IF (associated(id%A)) THEN DO I=1,id%NZ IF (id%KEEP(50).NE.0 .AND. id%IRN(I).LT.id%JCN(I)) THEN WRITE(IUNIT,*) id%JCN(I), id%IRN(I), & real(id%A(I)), aimag(id%A(I)) ELSE WRITE(IUNIT,*) id%IRN(I), id%JCN(I), & real(id%A(I)), aimag(id%A(I)) ENDIF ENDDO ELSE DO I=1,id%NZ IF (id%KEEP(50).NE.0 .AND. id%IRN(I).LT.id%JCN(I)) THEN WRITE(IUNIT,*) id%JCN(I), id%IRN(I) ELSE WRITE(IUNIT,*) id%IRN(I), id%JCN(I) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN 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, id%NZ_loc IF (associated(id%A_loc)) THEN DO I=1,id%NZ_loc IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I), & real(id%A_loc(I)), aimag(id%A_loc(I)) ELSE WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I), & real(id%A_loc(I)), aimag(id%A_loc(I)) ENDIF ENDDO ELSE DO I=1,id%NZ_loc IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I) ELSE WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_166 SUBROUTINE CMUMPS_179(IUNIT, id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT CHARACTER (LEN=8) :: ARITH INTEGER :: I, J, K, LD_RHS 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_179 SUBROUTINE CMUMPS_649( NSLAVES, NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND 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 RETURN END SUBROUTINE CMUMPS_649 SUBROUTINE CMUMPS_251(N,IW,LIW,A,LA, & NSTK_STEPS, NBPROCFILS,IFLAG,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, IERROR,IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, & LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST_S, 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) USE CMUMPS_LOAD USE CMUMPS_OOC IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER N,IFLAG,NTOTPV,MAXFRT,LIW, LPTRAR, NMAXNPIV, & IERROR, 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 PTRARW(LPTRAR), PTRAIW(LPTRAR), ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST_S(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 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 ) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX DBLARR( max(1,KEEP(13)) ) LOGICAL IS_ISOLATED_NODE INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBRTOT, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS 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_330, MUMPS_275 INTEGER MUMPS_330, MUMPS_275 LOGICAL MUMPS_167,MUMPS_283 EXTERNAL MUMPS_167,MUMPS_283 LOGICAL CMUMPS_508 EXTERNAL CMUMPS_508, CMUMPS_509 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 ASS_IRECV = MPI_REQUEST_NULL ITLOC(1:N+KEEP(253)) =0 PTRIST (1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRAST(1:KEEP(28))=0_8 PTRFAC(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_22( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, & IFLAG, IERROR & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 NBPROCFILS(1:KEEP(28)) = 0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL CMUMPS_284( & 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, IFLAG, KEEP,KEEP8, IERROR ) ENDIF IF ( IFLAG .LT. 0 ) GOTO 635 END IF 20 CONTINUE NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( & 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_STEPS, & COMP, IFLAG, & IERROR, COMM_NODES, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED ) CALL CMUMPS_467(COMM_LOAD, KEEP) IF (MESSAGE_RECEIVED) THEN IF ( IFLAG .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. CMUMPS_508( IPOOL, LPOOL) )THEN CALL CMUMPS_509( 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_500( & 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_501( & 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_512(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_242(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_330(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_144( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, & NPVW, & COMM_NODES, MYID_NODES, 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_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) IF ( IFLAG .LT. 0 ) GOTO 640 ELSE CALL CMUMPS_141( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, & NPVW, & COMM_NODES, MYID_NODES, 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_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) IF ( IFLAG .LT. 0 ) GOTO 640 IF ( IW( PTLUST_S(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_176( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & IFLAG, IERROR, COMM_NODES, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL CMUMPS_36( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ELSE JOBASS = 0 CALL CMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF IF ( IFLAG .LT. 0 ) GOTO 640 IF ((NBPROCFILS(STEP(INODE)).GT.0).OR.(SON_LEVEL2)) GOTO 20 ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL CMUMPS_253(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & IFLAG, IERROR, & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & ) ELSE CALL CMUMPS_37( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, IFLAG, IERROR, & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0)) END IF IF (IFLAG.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_251", POSELT CALL MUMPS_ABORT() ENDIF CALL CMUMPS_87 & ( IW(PTLUST_S(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST_S(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_143( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & IFLAG, UU, NOFFW, NPVW, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL CMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL CMUMPS_140( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & IFLAG, UU, NOFFW, NPVW, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL CMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_330(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) ELSE TYPEF = -9999 END IF CALL CMUMPS_254( 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,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 ) IF (IFLAG.LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in CMUMPS_251: ', & ' 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_681(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL CMUMPS_580(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in CMUMPS_251: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in CMUMPS_251: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL CMUMPS_242( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_275(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_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF)) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL CMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE CALL CMUMPS_44( MYID_NODES, SLAVEF, COMM_NODES ) 640 CONTINUE CALL CMUMPS_255( INFO(1), & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL CMUMPS_180( INFO(1), & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, MP) 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_275( & 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_S(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_731(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before CMUMPS_146', LBUFRX CALL MUMPS_ABORT() ENDIF IS_BUFRX_ALLOCATED = .FALSE. ENDIF CALL CMUMPS_146( MYID_NODES, & root, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST_S, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_275(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_729(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 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL CMUMPS_688 & ( 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_576(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in CMUMPS_576' CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 IF (KEEP(252).NE.0) THEN CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLU) ELSE CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLU) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLU) 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_731(LRHS_CNTR_MASTER_ROOT,INFO(2)) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before CMUMPS_146', & 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_156( 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_S(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 CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-NFRONT8*NFRONT8,KEEP,KEEP8,LRLU) ENDIF ENDIF END IF END IF END IF IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_275(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_251 SUBROUTINE CMUMPS_87( 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' CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE CMUMPS_87 SUBROUTINE CMUMPS_136( id ) USE CMUMPS_OOC USE CMUMPS_STRUC_DEF USE CMUMPS_COMM_BUFFER IMPLICIT NONE include 'mpif.h' TYPE( CMUMPS_STRUC ) :: id LOGICAL I_AM_SLAVE INTEGER IERR, MASTER PARAMETER ( MASTER = 0 ) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL CMUMPS_587(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_276(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 CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF NULLIFY(id%SCHUR_CINTERFACE) 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%POIDS)) THEN DEALLOCATE(id%POIDS) NULLIFY(id%POIDS) ENDIF 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 IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF 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) ENDIF IF (associated(id%POSINRHSCOMP)) THEN DEALLOCATE(id%POSINRHSCOMP) NULLIFY(id%POSINRHSCOMP) ENDIF 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 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_636(id) IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF 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 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%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%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 IF (id%KEEP8(24).EQ.0_8) THEN IF (associated(id%S)) DEALLOCATE(id%S) ELSE ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN CALL CMUMPS_57( IERR ) CALL CMUMPS_59( IERR ) END IF IF ( associated( id%BUFR ) ) DEALLOCATE( id%BUFR ) NULLIFY( id%BUFR ) RETURN END SUBROUTINE CMUMPS_136 SUBROUTINE CMUMPS_150(MYID,COMM,S,MAXS,MAXS_BYTES) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) INTEGER COMM, MYID, MAXS, MAXS_BYTES INTEGER S( MAXS ) INTEGER MSGTAG, MSGSOU, MSGLEN LOGICAL FLAG FLAG = .TRUE. DO WHILE ( FLAG ) CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) IF (FLAG) THEN MSGTAG=STATUS(MPI_TAG) MSGSOU=STATUS(MPI_SOURCE) CALL MPI_GET_COUNT(STATUS,MPI_PACKED,MSGLEN,IERR) IF (MSGLEN <= MAXS_BYTES) THEN CALL MPI_RECV(S(1),MAXS_BYTES,MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR) ELSE EXIT ENDIF END IF END DO CALL MPI_BARRIER( COMM, IERR ) RETURN END SUBROUTINE CMUMPS_150 SUBROUTINE CMUMPS_254(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, & 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 ) USE CMUMPS_COMM_BUFFER 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) 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) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(max(1,KEEP(13))) INTEGER INTARR(max(1,KEEP(14))) 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 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_275 EXTERNAL MUMPS_275 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_167, &MUMPS_170 EXTERNAL MUMPS_167, MUMPS_170 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_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SSARBR_ROOT = MUMPS_170 & (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(*,*) "Error 1 in G" 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_511( 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_190(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_511( 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_190(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_511(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (SSARBR_ROOT) THEN CALL CMUMPS_190(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL CMUMPS_190(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_80( & 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, .FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_275(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_273( 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, & COMM, COMM_LOAD, FILS, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL CMUMPS_76( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE.) 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_275(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_275( 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_66( 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, IERR ) ELSE IF ( (TYPE.EQ.2).AND.(KEEP(48).NE.0)) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL CMUMPS_70( 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_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_254", 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_254", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_275(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_22( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,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_275(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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_652( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, COMPRESSCB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL CMUMPS_705( 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_651( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED ) 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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_93(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1) CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE CMUMPS_254 SUBROUTINE CMUMPS_142( id) USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD USE CMUMPS_OOC USE CMUMPS_STRUC_DEF IMPLICIT NONE #ifndef SUN_ INTERFACE SUBROUTINE CMUMPS_27(id, ANORMINF, LSCAL) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET :: id REAL, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL END SUBROUTINE CMUMPS_27 END INTERFACE #endif TYPE(CMUMPS_STRUC), TARGET :: id INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INCLUDE 'mumps_headers.h' INTEGER NSEND, NSEND_TOT, LDPTRAR, NELT INTEGER NLOCAL, NLOCAL_TOT, KEEP13_SAVE, ITMP INTEGER(8) K67 INTEGER(8) ITMP8 INTEGER MUMPS_275 EXTERNAL MUMPS_275 INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL INTEGER CMUMPS_LBUF, CMUMPS_LBUFR_BYTES, CMUMPS_LBUF_INT INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, NSTEPS, K28, LPOOL, LIW INTEGER IRANK, ID_ROOT INTEGER KKKK, NZ_locMAX 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 REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233 INTEGER COLOUR, COMM_FOR_SCALING INTEGER LIWK, LWK, LWK_REAL LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED 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, 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 INTEGER, POINTER :: JOB, NZ REAL,DIMENSION(:),POINTER::RINFO, RINFOG REAL,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER::INFO, 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(8),DIMENSION(:),POINTER::KEEP8 INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL CMUMPS_505 INTEGER CMUMPS_505 INTEGER(8) TOTAL_BYTES INTEGER(8) :: I8TMP INTEGER numroc EXTERNAL numroc COMPLEX, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED JOB=>id%JOB NZ=>id%NZ RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFO=>id%INFO INFOG=>id%INFOG KEEP=>id%KEEP KEEP8=>id%KEEP8 ICNTL=>id%ICNTL IF (id%NZ_loc .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 ) NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. IF (KEEP8(24).GT.0_8) THEN NULLIFY(id%S) ENDIF WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN KEEP8(24) = int(id%LWK_USER,8) ELSE KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE KEEP8(24) = 0_8 ENDIF KEEP13_SAVE = KEEP(13) id%DKEEP(4)=-1.0E0 id%DKEEP(5)=-1.0E0 MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LP = ICNTL( 1 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) 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. 0 ) 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 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN KEEP(201)=id%ICNTL(22) IF (KEEP(201) .NE. 0) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF 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(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 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 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 IF ( KEEP(50) .eq. 1 ) THEN IF (id%CNTL(1) .ne. ZERO ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') &' ** Warning : SPD solver called, resetting CNTL(1) to 0.0E0' END IF END IF id%CNTL(1) = ZERO END IF IF (KEEP(219).NE.0) THEN CALL CMUMPS_617(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN INFO(1) = -13 INFO(2) = max(KEEP(108),1) END IF ENDIF IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN 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 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: sparse RHS incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 IF ( PROKG ) THEN WRITE( MPG, 172 ) id%NSLAVES, id%ICNTL(22), & KEEP8(111), KEEP(126), KEEP(127), KEEP(28) IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) ENDIF IF (KEEP(201).LE.0) THEN KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF 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 KEEP(260) = 1 id%DKEEP(6) = 1.0E0 id%DKEEP(7) = 0.0E0 ENDIF 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 IF ( id%MYID.EQ.MASTER ) THEN ENDIF IF (KEEP(52) .EQ. 7) THEN K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_REAL,MASTER, & id%COMM,IERR) IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN 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 INFO(1)=-13 INFO(2)=LIWK+M+N+4* (id%NPROCS) ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 BUJOB = 1 LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL)) CALL CMUMPS_693( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%NZ_loc, & 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 INFO(1)=-13 INFO(2)=LIWK ENDIF ENDIF LWK_REAL = BURESZ DEALLOCATE(WK_REAL) ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=LWK_REAL ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 BUJOB = 2 CALL CMUMPS_693( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%NZ_loc, & 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 DEALLOCATE(IWK, WK_REAL,BURP,BUCP,BURS, BUCS) ELSE IF ( KEEP(54) .EQ. 0 ) THEN IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN 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 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 INFO(1)=-13 INFO(2)=1 ENDIF IF (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_693( & id%IRN(1), id%JCN(1), id%A(1), & id%NZ, & 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 INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL CMUMPS_693(id%IRN(1), & id%JCN(1), id%A(1), & id%NZ, & 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 DEALLOCATE(WK_REAL) DEALLOCATE (IWK,BURP,BUCP, & BURS,BUCS) ENDIF CALL MPI_BCAST( id%DKEEP(4),2,MPI_REAL, & MASTER, id%COMM, IERR ) 400 CONTINUE IF (id%MYID.EQ.MASTER) THEN CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF (INFO(1).LT.0) GOTO 530 ELSE IF (id%MYID.EQ.MASTER) THEN IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN IF ( KEEP(52) .eq. 5 .or. & KEEP(52) .eq. 6 ) THEN LWK = NZ ELSE LWK = 1 END IF LWK_REAL = 5 * N ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK_REAL GOTO 137 END IF ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK GOTO 137 END IF CALL CMUMPS_217(N, NZ, 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), INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN 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 = (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_761(id%ROWSCA(I), & id%DKEEP(6), & KEEP(259)) ENDDO IF (KEEP(50) .EQ. 0) THEN DO I = 1, id%N CALL CMUMPS_761(id%COLSCA(I), & id%DKEEP(6), & KEEP(259)) ENDDO ELSE CALL CMUMPS_765(id%DKEEP(6), KEEP(259)) ENDIF CALL CMUMPS_766(id%DKEEP(6), KEEP(259)) ENDIF 137 CONTINUE 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 ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N id%KEEP(255) = N*id%KEEP(253) ALLOCATE(RHS_MUMPS(id%KEEP(255)),stat=IERR) IF (IERR > 0) THEN INFO(1)=-13 INFO(2)=id%KEEP(255) IF (LP > 0) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ELSE id%KEEP(254)=id%LRHS id%KEEP(255)=id%LRHS*(id%KEEP(253)-1)+id%N RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN 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 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 ELSE id%KEEP(255)=1 ALLOCATE(RHS_MUMPS(1)) RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).lt.0 ) GOTO 530 KEEP(110)=ICNTL(24) CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(110).NE.1) KEEP(110)=0 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) ANORMINF = ZERO IF (KEEP(19).EQ.0) THEN SEUIL = ZERO ELSE CALL CMUMPS_27( id , ANORMINF, LSCAL ) IF (CNTL6 .LT. ZERO) THEN SEUIL = EPS*ANORMINF ELSE SEUIL = CNTL6*ANORMINF ENDIF IF (PROKG) WRITE(MPG,*) & ' ABSOLUTE PIVOT THRESHOLD for rank revealing =',SEUIL ENDIF SEUIL_LDLT_NIV2 = SEUIL IF (KEEP(110).EQ.0) THEN id%DKEEP(1) = -1.0E0 id%DKEEP(2) = ZERO ELSE IF (ANORMINF.EQ.ZERO) & CALL CMUMPS_27( id , ANORMINF, LSCAL ) IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE id%DKEEP(1) = 1.0E-5*EPS*ANORMINF 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 id%DKEEP(2) = -max(1.0E10*ANORMINF, & sqrt(huge(ANORMINF))/1.0E8) ELSE id%DKEEP(2) = ZERO ENDIF ENDIF ENDIF IF (KEEP(53).NE.0) THEN ID_ROOT =MUMPS_275(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%NSLAVES) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF IF ( associated( id%PIVNUL_LIST) ) DEALLOCATE(id%PIVNUL_LIST) IF(KEEP(110) .EQ. 1) THEN LPN_LIST = N ELSE LPN_LIST = 1 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 INFO(1)=-13 INFO(2)=LPN_LIST END IF id%PIVNUL_LIST(1:LPN_LIST) = 0 KEEP(109) = 0 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).lt.0 ) GOTO 530 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_REAL, & MASTER, id%COMM, IERR ) IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN IF(ANORMINF .EQ. ZERO) THEN CALL CMUMPS_27( id , ANORMINF, LSCAL ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL ELSE SEUIL = ZERO ENDIF ENDIF KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 IF ( id%MYID.EQ.MASTER ) THEN ITMP = ICNTL(23) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (WK_USER_PROVIDED) ITMP = 0 ITMP8 = int(ITMP, 8) KEEP8(4) = ITMP8 * 1000000_8 PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8=KEEP8(12) ELSE MAXS_BASE8=KEEP8(14) ENDIF IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) ELSE IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) IF (MAXS_BASE_RELAXED8 > huge(MAXS)) THEN WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ENDIF MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) MAXS = MAXS_BASE_RELAXED8 ELSE MAXS = 1_8 MAXS_BASE_RELAXED8 = 1_8 END IF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) .LT. 0) THEN GOTO 530 ENDIF IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN IF (KEEP(96).GT.0) THEN MAXS=int(KEEP(96),8) ELSE IF (KEEP8(4) .NE. 0_8) THEN PERLU_ON = .TRUE. CALL CMUMPS_214( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., KEEP(201), & PERLU_ON, TOTAL_BYTES) MAXS_BASE_RELAXED8=MAXS_BASE_RELAXED8 + & (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 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,4) ELSE MAXS=MAXS_BASE_RELAXED8 ENDIF ENDIF ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) .LT. 0) THEN GOTO 530 ENDIF CALL CMUMPS_713(PROKG, MPG, MAXS, id%NSLAVES, & id%COMM, "effective relaxed size of S =") CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF IF ( I_AM_SLAVE ) THEN CALL CMUMPS_188( dble(id%COST_SUBTREES), & KEEP(64), KEEP(66),MAXS ) K28=KEEP(28) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), & max(0_8, MAXS-MAXS_BASE8)) CALL CMUMPS_185( id, MEMORY_MD_ARG, MAXS ) CALL CMUMPS_587(id, IERR) IF (IERR < 0) THEN INFO(1) = -90 INFO(2) = 0 GOTO 112 ENDIF IF (KEEP(201) .GT. 0) THEN IF (KEEP(201).EQ.1 & .AND.KEEP(50).EQ.0 & .AND.KEEP(251).NE.2 & ) THEN OOC_NB_FILE_TYPE=2 ELSE OOC_NB_FILE_TYPE=1 ENDIF IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN I8TMP = int(OOC_NB_FILE_TYPE,8) * 2_8 * int(KEEP(226),8) ELSE I8TMP = 2_8 * KEEP8(119) ENDIF I8TMP = I8TMP + int(max(KEEP(12),0),8) * & (I8TMP/100_8+1_8) I8TMP = min(I8TMP, 12000000_8) KEEP(100)=int(I8TMP) ENDIF IF (KEEP(201).EQ.1) THEN IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF IF (id%MYID_NODES .eq. MASTER) THEN write(6,*) ' PANEL: INIT and force STRAT_IO= ', & id%KEEP(99) ENDIF ENDIF 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), & OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) < 0) THEN 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_575(id,MAXS) ELSE WRITE(*,*) "Internal error in CMUMPS_142" CALL MUMPS_ABORT() ENDIF IF(INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF #if ! defined(OLD_LOAD_MECHANISM) CALL CMUMPS_190(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) #endif IF (INFO(1).LT.0) GOTO 111 #if defined(stephinfo) write(*,*) 'proc ',id%MYID,' array of dist : ', & id%MEM_DIST(0:id%NSLAVES - 1) #endif END IF IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN ALLOCATE (id%S(MAXS),stat=IERR) KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_735(MAXS, INFO(2)) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ELSE id%S => id%WK_USER(1:KEEP8(24)) ENDIF #if defined (LARGEMATRICES) END IF #endif 111 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP(55) .eq. 0 ) THEN IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE .and. KEEP(13) .ne. 0 ) THEN ALLOCATE( id%DBLARR( KEEP(13) ), stat = IERR ) ELSE ALLOCATE( id%DBLARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID, & ':Error allocating DBLARR : IERR = ', IERR INFO(1)=-13 INFO(2)=KEEP(13) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( I_AM_SLAVE .and. KEEP(14) .ne. 0 ) THEN ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = KEEP(14) 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 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 id%DBLARR => id%A_ELT ELSE IF ( KEEP(13) .ne. 0 ) THEN ALLOCATE( id%DBLARR( KEEP(13) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = KEEP(13) 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 IF ( KEEP(38).NE.0 .AND. I_AM_SLAVE ) THEN CALL CMUMPS_165( id%N, & id%root, id%FILS(1), KEEP(38), id%KEEP(1), id%INFO(1) ) END IF 100 CONTINUE CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP( 55 ) .eq. 0 ) THEN IF (KEEP(38).NE.0 .AND. I_AM_SLAVE) THEN LWK = numroc( id%root%ROOT_SIZE, id%root%MBLOCK, & id%root%MYROW, 0, id%root%NPROW ) LWK = max( 1, LWK ) LWK = LWK* & numroc( id%root%ROOT_SIZE, id%root%NBLOCK, & id%root%MYCOL, 0, id%root%NPCOL ) LWK = max( 1, LWK ) ELSE LWK = 1 ENDIF IF (MAXS .LT. int(LWK,8)) THEN INFO(1) = -9 INFO(2) = LWK ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN ALLOCATE(IWK(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN INFO(1)=-13 INFO(2)=id%N END IF #if defined(LARGEMATRICES) IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( .not. associated( id%INTARR ) ) THEN ALLOCATE( id%INTARR( 1 ) ) ENDIF #if defined(LARGEMATRICES) CALL CMUMPS_148(id%N, NZ, 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), & min(KEEP(39),id%NZ), & LP, id%COMM, id%root, KEEP,KEEP8, & id%FILS(1), IWK(1), & & id%INTARR(1), id%DBLARR(1), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), int(LWK,8), & id%ISTEP_TO_INIV2, id%I_AM_CAND, & id%CANDIDATES) write(6,*) '!!! A,IRN,JCN are freed during facto ' 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) KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = MAXS NULLIFY(id%S) KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ELSE id%S => id%WK_USER(1:KEEP8(24)) ENDIF id%S(MAXS-LWK+1:MAXS) = WK(1:LWK) DEALLOCATE (WK) #else CALL CMUMPS_148(id%N, NZ, 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), & min(KEEP(39),id%NZ), & LP, id%COMM, id%root, KEEP(1),KEEP8(1), & id%FILS(1), IWK(1), & & id%INTARR(1), id%DBLARR(1), & 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) IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF ELSE CALL CMUMPS_145( id%N, & id%DBLARR( 1 ), max(1,KEEP( 13 )), & id%INTARR( 1 ), max(1,KEEP( 14 )), & id%PTRAR( 1 ), & id%PTRAR(id%N+1), & KEEP( 1 ), KEEP8(1), id%MYID, id%COMM, & min(id%KEEP(39),id%NZ), & & 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 IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( I_AM_SLAVE ) THEN NZ_locMAX = 0 CALL MPI_ALLREDUCE(id%NZ_loc, NZ_locMAX, 1, MPI_INTEGER, & MPI_MAX, id%COMM_NODES, IERR) CALL CMUMPS_282( id%N, & id%NZ_loc, & id, & id%DBLARR(1), KEEP(13), id%INTARR(1), & KEEP(14), id%PTRAR(1), id%PTRAR(id%N+1), & KEEP(1), KEEP8(1), id%MYID_NODES, & id%COMM_NODES, min(id%KEEP(39),NZ_locMAX), & 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), NSEND, NLOCAL, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN 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) 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) NLOCAL, NSEND END IF END IF IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN NSEND = 0 NLOCAL = 0 END IF CALL MPI_REDUCE( NSEND, NSEND_TOT, 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL, NLOCAL_TOT, 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT, NSEND_TOT END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF END IF ELSE IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( id%MYID.eq.MASTER) &CALL CMUMPS_213( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) CALL CMUMPS_126( id%N, id%NELT, id%NA_ELT, & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & id%INTARR(1), id%DBLARR(1), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & id%S(1), MAXS, id%FILS(1), & id, id%root ) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF END IF IF ( I_AM_SLAVE ) THEN CALL CMUMPS_528(id%MYID_NODES) CMUMPS_LBUFR_BYTES = KEEP( 44 ) * KEEP( 35 ) CMUMPS_LBUFR_BYTES = max( CMUMPS_LBUFR_BYTES, & 100000 ) PERLU = KEEP( 12 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF CMUMPS_LBUFR_BYTES = CMUMPS_LBUFR_BYTES & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUFR_BYTES)/100E0) IF (KEEP(48)==5) THEN KEEP8(21) = KEEP8(22) + int( real(max(PERLU,MIN_PERLU))* & real(KEEP8(22))/100E0,8) ENDIF CMUMPS_LBUF = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(43)) * real(KEEP(35)) ) CMUMPS_LBUF = max( CMUMPS_LBUF, 100000 ) CMUMPS_LBUF = CMUMPS_LBUF & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUF)/100E0) CMUMPS_LBUF = max(CMUMPS_LBUF, CMUMPS_LBUFR_BYTES+3*KEEP(34)) IF(id%KEEP(48).EQ.4)THEN CMUMPS_LBUFR_BYTES=CMUMPS_LBUFR_BYTES*5 CMUMPS_LBUF=CMUMPS_LBUF*5 ENDIF CMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN KKKK = MUMPS_275( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%NSLAVES ) IF ( KKKK .EQ. id%MYID_NODES ) THEN CMUMPS_LBUF_INT = CMUMPS_LBUF_INT + & 10 * & 2 * ( id%NE_STEPS(id%STEP(KEEP(38))) + 1 ) * id%NSLAVES & * KEEP(34) END IF END IF IF ( MP .GT. 0 ) 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) CALL CMUMPS_55( CMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID, & ':Error allocating small Send buffer:IERR=' & ,IERR INFO(1)= -13 INFO(2)= (CMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) GO TO 110 END IF CALL CMUMPS_53( CMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating Send buffer:IERR=' & ,IERR INFO(1)= -13 INFO(2)= (CMUMPS_LBUF+KEEP(34)-1)/KEEP(34) GO TO 110 END IF 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 WRITE(*,*) id%MYID,':Error allocating BUFR:IERR=' & ,IERR INFO(1)=-13 INFO(2)=id%LBUFR NULLIFY(id%BUFR) GO TO 110 END IF PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN MAXIS_ESTIM = KEEP(225) ELSE 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 WRITE(*,*) id%MYID,':Error allocating IS:IERR=',IERR INFO(1)=-13 INFO(2)=MAXIS NULLIFY(id%IS) GO TO 110 END IF LIW = MAXIS IF (associated( id%PTLUST_S )) DEALLOCATE(id%PTLUST_S) ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocatingPTLUST:IERR = ', & IERR INFO(1)=-13 INFO(2)=id%KEEP(28) 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 WRITE(*,*) id%MYID,':Error allocatingPTRFAC:IERR = ', & IERR INFO(1)=-13 INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) GOTO 100 END IF PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 3 * id%KEEP(28) IPOOL = ITLOC + id%N + id%KEEP(253) LPOOL = CMUMPS_505(id%KEEP(1),id%KEEP8(1)) ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', & IERR INFO(1)=-13 INFO(2)=IPOOL + LPOOL - 1 GOTO 110 END IF ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', & IERR INFO(1)=-13 INFO(2)=2 * id%KEEP(28) GOTO 110 END IF ENDIF 110 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN CALL CMUMPS_60( id%LBUFR_BYTES ) IF (MP .GT. 0) THEN WRITE( MP, 170 ) MAXS, MAXIS, KEEP8(12), KEEP(15), KEEP(13), & KEEP(14), KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF PERLU_ON = .TRUE. CALL CMUMPS_214( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) id%INFO(16) = TOTAL_MBYTES IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' ** Space in MBYTES used during factorization :', & id%INFO(16) END IF CALL MUMPS_243( 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 KEEP8(31)= 0_8 KEEP8(10) = 0_8 KEEP8(8)=0_8 INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = id%N ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT = id%NELT ELSE NELT = 1 END IF CALL CMUMPS_244( 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), INFO(1), RINFO(1), KEEP(1),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, 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) IF ( MP . GT. 0 .and. KEEP(38) .ne. 0 ) THEN WRITE( MP, 175 ) KEEP(49) END IF DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF IF ( KEEP(55) .eq. 0 ) THEN IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF ELSE DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN NULLIFY( id%DBLARR ) ELSE IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF END IF IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN 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 IF (associated(id%BUFR)) THEN DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) END IF CALL CMUMPS_57( IERR ) CALL CMUMPS_59( IERR ) IF (KEEP(219).NE.0) THEN CALL CMUMPS_620() ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) CALL CMUMPS_770(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_591(IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ENDIF ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) END IF END IF IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,180) TIME END IF PERLU_ON = .TRUE. CALL CMUMPS_214( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) KEEP8(7) = TOTAL_BYTES id%INFO(22) = TOTAL_MBYTES IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' ** Effective minimum Space in MBYTES for facto :', & TOTAL_MBYTES ENDIF IF (I_AM_SLAVE) THEN K67 = KEEP8(67) ELSE K67 = 0_8 ENDIF CALL MUMPS_735(K67,id%INFO(21)) CALL CMUMPS_713(PROKG, MPG, K67, id%NSLAVES, & id%COMM, "effective space used in S (KEEP8(67) =") CALL MUMPS_243( 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 KEEP(33) = INFO(11) CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_646( KEEP8(31),KEEP8(6), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(6), INFOG(9)) CALL MPI_REDUCE( INFO(10), INFOG(10), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_ALLREDUCE( INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) KEEP(133) = INFOG(11) CALL MPI_REDUCE( 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) INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) CALL MUMPS_646( KEEP8(8), KEEP8(108), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(10), INFO(27)) CALL MUMPS_646( KEEP8(10),KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(110), INFOG(29)) IF (KEEP(258).NE.0) THEN IF (KEEP(260).EQ.-1) THEN id%DKEEP(6)=-id%DKEEP(6) id%DKEEP(7)=-id%DKEEP(7) ENDIF CALL CMUMPS_764( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN IF (id%KEEP(23).NE.0) THEN CALL CMUMPS_767( & RINFOG(12), id%N, & id%STEP(1), & id%UNS_PERM(1) ) ENDIF ENDIF ENDIF IF(KEEP(110) .EQ. 1) THEN INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF INFOG(28)=KEEP(112)+KEEP(17) IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN INFO(18)=INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN DO I=1, KEEP(17) id%PIVNUL_LIST(KEEP(112)+I)=id%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE 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 IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%NPROCS END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (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 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) 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 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) IF ( PROKG ) THEN WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP8(6),INFOG(10), & INFOG(11), KEEP8(110) IF (id%KEEP(50) == 0) THEN WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN WRITE(MPG, 99986) KEEP(98) ENDIF IF (id%KEEP(50) == 2) THEN WRITE(MPG, 99988) KEEP(229) WRITE(MPG, 99989) KEEP(230) ENDIF IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) IF (KEEP(110).NE.0.OR.KEEP(17).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) WRITE(MPG, 99981) INFOG(14) IF ((KEEP(201).EQ.0.OR.KEEP(201).EQ.2).AND. & KEEP(50).EQ.0) THEN WRITE(MPG, 99980) KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN 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 500 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL CMUMPS_592(id,IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ELSE IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 END IF END IF 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL CMUMPS_183( INFO(1), IERR ) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) 530 CONTINUE IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) id%KEEP(13) = KEEP13_SAVE RETURN 120 FORMAT(/' LOCAL REDISTRIB: DATA LOCAL/SENT =',I12,I12) 125 FORMAT(/' REDISTRIB: TOTAL DATA LOCAL/SENT =',I12,I12) 130 FORMAT(/' ****** FACTORIZATION STEP ********'/) 160 FORMAT(' GLOBAL TIME FOR MATRIX DISTRIBUTION =',F12.4) 165 FORMAT(' Convergence error after scaling for INF-NORM', & ' (option 7/8) =',D9.2) 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 =',I12/ & ' Size of internal working array IS =',I12/ & ' MINIMUM (ICNTL(14)=0) size of S =',I12/ & ' MINIMUM (ICNTL(14)=0) size of IS =',I12/ & ' REAL SPACE FOR ORIGINAL MATRIX =',I12/ & ' INTEGER SPACE FOR ORIGINAL MATRIX =',I12/ & ' REAL SPACE FOR FACTORS =',I12/ & ' INTEGER SPACE FOR FACTORS =',I12/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12) 172 FORMAT(/' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' NUMBER OF WORKING PROCESSES =',I12/ & ' OUT-OF-CORE OPTION (ICNTL(22)) =',I12/ & ' REAL SPACE FOR FACTORS =',I12/ & ' INTEGER SPACE FOR FACTORS =',I12/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12/ & ' NUMBER OF NODES IN THE TREE =',I12) 173 FORMAT( ' PERFORM FORWARD DURING FACTO, NRHS =',I12) 175 FORMAT(/' NUMBER OF ENTRIES FOR // ROOT =',I12) 180 FORMAT(/' ELAPSED TIME FOR FACTORIZATION =',F12.4) 99977 FORMAT( ' INFOG(34) DETERMINANT (base 2 exponent) =',I12) 99978 FORMAT( ' RINFOG(12) DETERMINANT (real part) =',F12.4) 99979 FORMAT( ' RINFOG(12) DETERMINANT (imaginary part) =',F12.4) 99980 FORMAT( ' KEEP8(108) Extra copies IP stacking =',I12) 99981 FORMAT( ' INFOG(14) NUMBER OF MEMORY COMPRESS =',I12) 99982 FORMAT( ' INFOG(13) NUMBER OF DELAYED PIVOTS =',I12) 99983 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(16) =',I12) 99991 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(24) =',I12) 99992 FORMAT( ' INFOG(28) ESTIMATED DEFICIENCY =',I12) 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 =',I12/ & ' INFOG(10) INTEGER SPACE FOR FACTORS =',I12/ & ' INFOG(11) MAXIMUM FRONT SIZE =',I12/ & ' INFOG(29) NUMBER OF ENTRIES IN FACTORS =',I12) 99985 FORMAT( ' INFOG(12) NB OF OFF DIAGONAL PIVOTS =',I12) 99986 FORMAT( ' INFOG(25) NB TINY PIVOTS/STATIC PIVOTING =',I12) 99988 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 1 nodes =',I12) 99989 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 2 nodes =',I12) END SUBROUTINE CMUMPS_142 SUBROUTINE CMUMPS_713(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 INTEGER(8) MAX_VAL INTEGER IERR, MASTER REAL LOC_VAL, AVG_VAL PARAMETER(MASTER=0) CALL MUMPS_646( 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,I12) END SUBROUTINE CMUMPS_713 SUBROUTINE CMUMPS_770(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR, MASTER 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 INTEGER MUMPS_275 EXTERNAL MUMPS_275 IF (id%INFO(1) .LT. 0) RETURN IF (id%KEEP(60) .EQ. 0) RETURN ID_SCHUR =MUMPS_275( & 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 IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE LD_SCHUR = -999999 SIZE_SCHUR = id%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ELSE RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN 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 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 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 IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF RETURN ENDIF IF (id%KEEP(252).EQ.0) THEN IF ( ID_SCHUR .EQ. MASTER ) THEN CALL CMUMPS_756( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE BL8=int(huge(BL4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) IF ( id%MYID .eq. ID_SCHUR ) THEN 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 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 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 CALL ccopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE 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 IF (id%KEEP(221).EQ.1) THEN 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 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 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_770 SUBROUTINE CMUMPS_83 & ( N, MAPPING, NZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NZ, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NZ ), JCN( NZ ) INTEGER MAPPING( NZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_275, MUMPS_330 EXTERNAL MUMPS_275, MUMPS_330 INTEGER K, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K INODE = FILS( INODE ) K = K + 1 END DO DO K = 1, NZ IOLD = IRN( K ) JOLD = JCN( K ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K ) = -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_330( PROCNODE(abs(STEP(IARR))), & SLAVEF ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_275( PROCNODE(abs(STEP(IARR))), & SLAVEF ) + 1 ELSE DEST = MUMPS_275( 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( K ) = DEST END DO RETURN END SUBROUTINE CMUMPS_83 SUBROUTINE CMUMPS_282( & N, NZ_loc, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND, NLOCAL, & ISTEP_TO_INIV2, CANDIDATES & ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NZ_loc TYPE (CMUMPS_STRUC) :: id INTEGER LDBLARR, LINTARR COMPLEX DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER 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_275, MUMPS_330, numroc, & MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, numroc, & MUMPS_810 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ), MSGSOU COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER END_MSG_2_RECV INTEGER I, K, I1, IA 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 IACT( SLAVEF ), IREQI( SLAVEF ), IREQR( SLAVEF ) LOGICAL SEND_ACTIVE( SLAVEF ) LOGICAL FLAG INTEGER NSEND, NLOCAL INTEGER MASTER_NODE, ISTEP NSEND = 0 NLOCAL = 0 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF 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 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_276( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) RETURN ARROW_ROOT = 0 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((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 K = 1, NZ_loc 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_102( & 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(K) JOLD = id%JCN_loc(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) CYCLE VAL = id%A_loc(K) 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_330( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE= MUMPS_275( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_810( 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 NLOCAL = NLOCAL + 1 NSEND = NSEND + SLAVEF -1 else if (DEST .eq.MYID ) then NLOCAL = NLOCAL + 1 else NSEND = NSEND + 1 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_101( 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_101( 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_101( 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_101( 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_101( 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_101( 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_102( & 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 DEALLOCATE( IW4 ) DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) DEALLOCATE( BUFRECI ) DEALLOCATE( BUFRECR ) RETURN END SUBROUTINE CMUMPS_282 SUBROUTINE CMUMPS_101( 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 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 PTRAIW( N ), PTRARW( N ), 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, 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_102( & 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_102( & 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_101 SUBROUTINE CMUMPS_102 & ( 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 PTRAIW( N ), PTRARW( N ), PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA COMPLEX A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID, & ILOCROOT, JLOCROOT INTEGER IA, IS1, ISHIFT, IIW, IS, IAS, 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_330( & 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 IA = PTRARW(IARR) DBLARR(IA) = DBLARR(IA) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL ENDIF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IPROC = MUMPS_275( 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_310( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE CMUMPS_102 SUBROUTINE CMUMPS_151( NRHS, N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER NRHS, N,LIWW,LWC,POSWCB,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28),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 SIZFR = SIZFR * NRHS IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE CMUMPS_151 SUBROUTINE CMUMPS_95(NRHS,N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER NRHS,N,LIWW,LWC,POSWCB,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28),PTRACB(KEEP28) COMPLEX W(LWC) INTEGER IPTIW,IPTA,SIZFI,SIZFR,LONGI,LONGR INTEGER I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = IWCB(IPTIW+1) SIZFI = 2 SIZFR = SIZFR * NRHS IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I ) 20 CONTINUE DO 30 I=0,LONGR-1 W(IPTA + SIZFR - I) = W(IPTA - I ) 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 = IWCB(IPTIW+1) SIZFI = 2 SIZFR = SIZFR * NRHS IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE CMUMPS_95 SUBROUTINE CMUMPS_205(MTYPE, IFLAG, N, NZ, & LHS, WRHS, W, RHS, GIVSOL, SOL, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,NZ,IFLAG,ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) COMPLEX RHS(N),LHS(N) COMPLEX WRHS(N),SOL(*) REAL W(N) REAL RESMAX,RESL2,XNORM, ERMAX,MAXSOL, & COMAX, SCLNRM, ERL2, ERREL REAL ANORM,DZERO,EPSI LOGICAL GIVSOL,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0E0 EPSI = 0.1E-9 ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RHS(K))) RESL2 = RESL2 + abs(RHS(K)) * abs(RHS(K)) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF (XNORM .GT. EPSI) THEN SCLNRM = RESMAX / (ANORM * XNORM) ELSE IFLAG = IFLAG + 2 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) &' max-NORM of computed solut. is zero' SCLNRM = RESMAX / ANORM ENDIF RESL2 = sqrt(RESL2) ERMAX = DZERO COMAX = DZERO ERL2 = DZERO IF (.NOT.GIVSOL) THEN IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM ELSE MAXSOL = DZERO DO 60 K = 1, N MAXSOL = max(MAXSOL, abs(SOL(K))) 60 CONTINUE DO 70 K = 1, N ERL2 = abs(LHS(K) - SOL(K)) ** 2 + ERL2 ERMAX = max(ERMAX, abs(LHS(K) - SOL(K))) 70 CONTINUE DO 80 K = 1, N IF (abs(SOL(K)) .GT. EPSI) THEN COMAX = max(COMAX, (abs(LHS(K) - SOL(K)) / abs(SOL(K)))) ENDIF 80 CONTINUE ERL2 = sqrt(ERL2) IF (MAXSOL .GT. EPSI) THEN ERREL = ERMAX / MAXSOL ELSE IFLAG = IFLAG + 2 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) &' MAX-NORM of exact solution is zero' ERREL = ERMAX ENDIF IF (PROK) WRITE( MPRINT, 100 ) ERMAX, ERL2, ERREL, COMAX, RESMAX & , RESL2, ANORM, XNORM, SCLNRM ENDIF 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 100 FORMAT (/' ERROR IS ............ (MAX-NORM) =',1PD9.2/ & ' ............ (2-NORM) =',1PD9.2/ & ' RELATIVE ERROR........... (MAX-NORM) =',1PD9.2/ & ' Comp. Wise ERROR......... (MAX-NORM) =',1PD9.2/ & ' AND RESIDUAL IS ......... (MAX-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' NORM OF input MATRIX ... (MAX-NORM) =',1PD9.2/ & ' NORM of computed SOLUT... (MAX-NORM) =',1PD9.2/ & ' SCALED RESIDUAL ......... (MAX-NORM) =',1PD9.2) END SUBROUTINE CMUMPS_205 SUBROUTINE CMUMPS_206(NZ, N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, JOB, COND, MAXIT, NOITER, LP, KEEP,KEEP8, & ARRET ) IMPLICIT NONE INTEGER NZ, N, KASE, KEEP(500), JOB 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, MAXIT, NOITER REAL COND(2),OMEGA(2) REAL ARRET REAL CGCE, CTAU DATA CTAU /1.0E3/, CGCE /0.2E0/ LOGICAL LCOND1, LCOND2 INTEGER IFLAG, JUMP, I, IMAX REAL ERX, DXMAX REAL CONVER, OM1, OM2, DXIMAX REAL ZERO, ONE,TAU, DD REAL OLDOMG(2) INTEGER CMUMPS_IXAMAX INTRINSIC abs, max SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX, CONVER, & OM1, OLDOMG, IFLAG DATA ZERO /0.0E0/, ONE /1.0E0/ IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO OM1 = ZERO IFLAG = 0 NOITER = 0 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 DO 20 I = 1, N X(I) = X(I) + Y(I) 20 CONTINUE IF (NOITER .GT. MAXIT) THEN IFLAG = IFLAG + 8 GOTO 70 ENDIF 30 CONTINUE KASE = 14 JUMP = 5 RETURN 35 CONTINUE IMAX = CMUMPS_IXAMAX(N, X, 1) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO 40 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 + TAU) .GT. TAU) 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 40 CONTINUE OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) GOTO 70 IF (MAXIT .EQ. 0) GOTO 70 IF (NOITER .GT. 1 .AND. OM2 .GT. OM1 * CGCE) THEN CONVER = OM2 / OM1 IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO 50 I = 1, N X(I) = C_W(I) 50 CONTINUE ENDIF GOTO 70 ENDIF DO 60 I = 1, N C_W(I) = X(I) 60 CONTINUE OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 NOITER = NOITER + 1 KASE = 2 JUMP = 2 RETURN 70 KASE = 0 IF (JOB .LE. 0) GOTO 170 DO 80 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 80 CONTINUE DO 90 I = 1, N C_W(I) = X(I) * D(I) 90 CONTINUE IMAX = CMUMPS_IXAMAX(N, C_W(1), 1) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CALL CMUMPS_218(N, KASE, Y, COND(1), C_W, IW(1, 2)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL CMUMPS_204(N, Y, D) IF (KASE .EQ. 2) CALL CMUMPS_204(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL CMUMPS_204(N, Y, R_W) IF (KASE .EQ. 2) CALL CMUMPS_204(N, Y, D) GOTO 100 120 IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CALL CMUMPS_218(N, KASE, Y, COND(2), C_W, IW(1, 2)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL CMUMPS_204(N, Y, D) IF (KASE .EQ. 2) CALL CMUMPS_204(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL CMUMPS_204(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL CMUMPS_204(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 KASE = -IFLAG RETURN END SUBROUTINE CMUMPS_206 SUBROUTINE CMUMPS_207(A, NZ, N, IRN, ICN, Z, KEEP,KEEP8) INTEGER NZ, N, I, J, K, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN(NZ), ICN(NZ) COMPLEX A(NZ) REAL Z(N) REAL ZERO INTRINSIC abs DATA ZERO /0.0E0/ DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1, NZ 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, NZ 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 RETURN END SUBROUTINE CMUMPS_207 SUBROUTINE CMUMPS_289(A, NZ, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA) INTEGER, intent(in) :: NZ, N, KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) COMPLEX, intent(in) :: A(NZ) REAL, intent(in) :: COLSCA(N) REAL, intent(out) :: Z(N) REAL ZERO DATA ZERO /0.0E0/ INTEGER I, J, K DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1, NZ 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, NZ 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_289 SUBROUTINE CMUMPS_208(A, NZ, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, intent(in) :: NZ, N, KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) COMPLEX, intent(in) :: A(NZ), RHS(N), X(N) REAL, intent(out) :: W(N) COMPLEX, intent(out) :: R(N) INTEGER I, K, J REAL ZERO DATA ZERO /0.0E0/ COMPLEX D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. (J .LT. 1)) & CYCLE D = A(K) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF ((I.NE.J) .AND. (KEEP(50).NE.0) ) THEN D = A(K) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_208 SUBROUTINE CMUMPS_204(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_204 SUBROUTINE CMUMPS_218(N, KASE, X, EST, W, IW) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) COMPLEX W(N), X(N) REAL 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_218 SUBROUTINE CMUMPS_278( MTYPE, N, NZ, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N, NZ INTEGER IRN( NZ ), ICN( NZ ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX, intent(in) :: ASPK( NZ ) COMPLEX, intent(in) :: LHS( N ), WRHS( N ) COMPLEX, intent(out):: RHS( N ) REAL, intent(out):: W( N ) INTEGER K, I, J REAL DZERO PARAMETER(DZERO = 0.0E0) DO 10 K = 1, N W(K) = DZERO RHS(K) = WRHS(K) 10 CONTINUE IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(I) = RHS(I) - ASPK(K) * LHS(J) W(I) = W(I) + abs(ASPK(K)) ENDDO ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(J) = RHS(J) - ASPK(K) * LHS(I) W(J) = W(J) + abs(ASPK(K)) ENDDO ENDIF ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(I) = RHS(I) - ASPK(K) * LHS(J) W(I) = W(I) + abs(ASPK(K)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K) * LHS(I) W(J) = W(J) + abs(ASPK(K)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_278 SUBROUTINE CMUMPS_121( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX A_ELT(NA_ELT) COMPLEX LHS( N ), WRHS( N ), RHS( N ) REAL W(N) CALL CMUMPS_257(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL CMUMPS_119( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE CMUMPS_121 SUBROUTINE CMUMPS_119( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX A_ELT(NA_ELT) REAL TEMP REAL W(N) INTEGER K, I, J, IEL, SIZEI, IELPTR REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K = 1 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( K )) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K)) K = K + 1 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( K )) K = K + 1 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K )) K = K + 1 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_119 SUBROUTINE CMUMPS_135(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL COLSCA(N) COMPLEX A_ELT(NA_ELT) REAL W(N) REAL TEMP, TEMP2 INTEGER K, I, J, IEL, SIZEI, IELPTR REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K = 1 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( K )) * TEMP2 K = K + 1 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( K )) * TEMP2 K = K + 1 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( K )*COLSCA(ELTVAR( IELPTR + J)) ) K = K + 1 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + I))) K = K + 1 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_135 SUBROUTINE CMUMPS_122( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR, NA_ELT INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) COMPLEX A_ELT( NA_ELT ), 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_122 SUBROUTINE CMUMPS_643( & 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_726(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_578(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_577( & 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_682(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_643 SUBROUTINE CMUMPS_257( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) COMPLEX A_ELT( * ), X( N ), Y( N ) INTEGER IEL, I , J, K, SIZEI, IELPTR COMPLEX TEMP COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) Y = 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 K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & 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 ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE CMUMPS_257 SUBROUTINE CMUMPS_192 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE INTEGER N, NZ_loc INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) COMPLEX A_loc( NZ_loc ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE INTEGER I, J, K COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ENDDO ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(I) ENDDO END IF ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE CMUMPS_192 SUBROUTINE CMUMPS_256( N, NZ, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM ) INTEGER N, NZ, LDLT, MTYPE, MAXTRANS INTEGER IRN( NZ ), ICN( NZ ) INTEGER PERM( N ) COMPLEX ASPK( NZ ), X( N ), Y( N ) INTEGER K, I, J COMPLEX PX( N ) COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) Y = ZERO 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 IF (MTYPE .EQ. 1) THEN DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K) * PX(J) ENDDO ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K) * PX(I) ENDDO ENDIF ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K) * 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 RETURN END SUBROUTINE CMUMPS_256 SUBROUTINE CMUMPS_193 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE INTEGER N, NZ_loc INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) COMPLEX A_loc( NZ_loc ), X( N ) REAL Y_loc( N ) INTEGER LDLT, MTYPE INTEGER I, J, K REAL RZERO PARAMETER( RZERO = 0.0E0 ) Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ) ENDDO ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(I) ) ENDDO END IF ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE CMUMPS_193 mumps-4.10.0.dfsg/src/cmumps_comm_buffer.F0000644000175300017530000031024011562233067020654 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE CMUMPS_COMM_BUFFER PRIVATE PUBLIC :: CMUMPS_61, CMUMPS_528, & CMUMPS_53 , CMUMPS_57 , & CMUMPS_55, CMUMPS_59, & CMUMPS_54,CMUMPS_58, & CMUMPS_66, CMUMPS_78, & CMUMPS_62, CMUMPS_68, & CMUMPS_71, CMUMPS_70, & CMUMPS_67, & CMUMPS_65, CMUMPS_64, & CMUMPS_72, & CMUMPS_648, CMUMPS_76, & CMUMPS_73, CMUMPS_74, & CMUMPS_63,CMUMPS_77, & CMUMPS_60, & CMUMPS_524, CMUMPS_469, & CMUMPS_460, CMUMPS_502, & CMUMPS_519 ,CMUMPS_620 & ,CMUMPS_617 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 BUF_LMAX_ARRAY REAL, DIMENSION(:), ALLOCATABLE :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY CONTAINS SUBROUTINE CMUMPS_528( MYID ) IMPLICIT NONE INTEGER MYID BUF_MYID = MYID RETURN END SUBROUTINE CMUMPS_528 SUBROUTINE CMUMPS_61( 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_61 SUBROUTINE CMUMPS_53( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL CMUMPS_2( BUF_CB, SIZE, IERR ) RETURN END SUBROUTINE CMUMPS_53 SUBROUTINE CMUMPS_55( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL CMUMPS_2( BUF_SMALL, SIZE, IERR ) RETURN END SUBROUTINE CMUMPS_55 SUBROUTINE CMUMPS_54( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL CMUMPS_2( BUF_LOAD, SIZE, IERR ) RETURN END SUBROUTINE CMUMPS_54 SUBROUTINE CMUMPS_58( IERR ) IMPLICIT NONE INTEGER IERR CALL CMUMPS_3( BUF_LOAD, IERR ) RETURN END SUBROUTINE CMUMPS_58 SUBROUTINE CMUMPS_620() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE CMUMPS_620 SUBROUTINE CMUMPS_617(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_617 SUBROUTINE CMUMPS_57( IERR ) IMPLICIT NONE INTEGER IERR CALL CMUMPS_3( BUF_CB, IERR ) RETURN END SUBROUTINE CMUMPS_57 SUBROUTINE CMUMPS_59( IERR ) IMPLICIT NONE INTEGER IERR CALL CMUMPS_3( BUF_SMALL, IERR ) RETURN END SUBROUTINE CMUMPS_59 SUBROUTINE CMUMPS_2( 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 CMUMPS_2 SUBROUTINE CMUMPS_3( 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 on SGI' 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 CMUMPS_3 SUBROUTINE CMUMPS_66( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, COMPRESSCB, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT 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_79( 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 NBROWS_PACKET = SIZE_AV_REALS / LCONT 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 CMUMPS_4( 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 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 CMUMPS_1( 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_66 SUBROUTINE CMUMPS_72( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, CB, SOL, & DEST, COMM, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR COMPLEX CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) COMPLEX SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) 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( 4, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_COMPLEX, COMM, & SIZE2, IERR ) SIZE = SIZE1 + SIZE2 CALL CMUMPS_4( 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 ) 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 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 CMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_72 SUBROUTINE CMUMPS_78( NRHS, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS, NODE1, NODE2, NCB, LONG INTEGER IW( max( 1, LONG ) ) COMPLEX W( max( 1, LDW * NRHS ) ) 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( 2+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS*LONG, MPI_COMPLEX, & COMM, SIZE2, IERR ) END IF SIZE = SIZE1 + SIZE2 CALL CMUMPS_4( 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 ) END IF 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 ) DO K=1, NRHS CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) END DO END IF CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), IERR ) IF ( SIZE .NE. POSITION ) CALL CMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_78 SUBROUTINE CMUMPS_62( I, DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER I INTEGER DEST, TAG, COMM, IERR 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 CMUMPS_4( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN write(6,*) ' Internal error in CMUMPS_62', & ' 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 ) CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR ) RETURN END SUBROUTINE CMUMPS_62 SUBROUTINE CMUMPS_469(FLAG) LOGICAL FLAG LOGICAL FLAG1, FLAG2, FLAG3 CALL CMUMPS_468( BUF_SMALL, FLAG1 ) CALL CMUMPS_468( BUF_CB, FLAG2 ) CALL CMUMPS_468( BUF_LOAD, FLAG3 ) FLAG = FLAG1 .AND. FLAG2 .AND. FLAG3 RETURN END SUBROUTINE CMUMPS_469 SUBROUTINE CMUMPS_468( B, FLAG ) TYPE ( CMUMPS_COMM_BUFFER_TYPE ) :: B LOGICAL :: FLAG INTEGER SIZE_AVAIL CALL CMUMPS_79(B, SIZE_AVAIL) FLAG = ( B%HEAD == B%TAIL ) RETURN END SUBROUTINE CMUMPS_468 SUBROUTINE CMUMPS_79( 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_79 SUBROUTINE CMUMPS_4( B, IPOS, IREQ, MSG_SIZE, IERR, & NDEST , PDEST & ) IMPLICIT NONE TYPE ( CMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER, INTENT(IN) :: MSG_SIZE INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR 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 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 CMUMPS_4 SUBROUTINE CMUMPS_1( 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 CMUMPS_1 SUBROUTINE CMUMPS_68( & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, & NASS, NSLAVES, LIST_SLAVES, & DEST, NFRONT, COMM, IERR ) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER INODE INTEGER NLIG, NCOL, NASS, NSLAVES INTEGER NBPROCFILS, DEST INTEGER ILIG( NLIG ) INTEGER ICOL( NCOL ) INTEGER LIST_SLAVES( NSLAVES ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER SIZE, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE = ( 6 + NLIG + NCOL + NSLAVES + 1 ) * SIZEofINT IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -2 RETURN END IF CALL CMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS 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 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 ) THEN WRITE(*,*) 'Error in CMUMPS_68 :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, MPI_PACKED, & DEST, MAITRE_DESC_BANDE, COMM, & BUF_CB%CONTENT( IREQ ), IERR ) RETURN END SUBROUTINE CMUMPS_68 SUBROUTINE CMUMPS_70( 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 ( ( KEEP(48).NE. 0 ).AND.(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_79( 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 CMUMPS_4( 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 ( ( KEEP(48).NE. 0 ).AND.(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 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 CMUMPS_1( 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_70 SUBROUTINE CMUMPS_67(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_617(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_729( 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_79( 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*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 ! defined(DBG_SMB3) 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 #endif CALL CMUMPS_4( 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 IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 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( 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_47( & 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_47( & 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_67" 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_618( & 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 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 CMUMPS_1( 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_67 SUBROUTINE CMUMPS_71( & 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF CALL CMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST & ) IF (IERR .LT. 0 ) THEN RETURN ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN 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 ) = NCBSON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF (( NSLAVES.GT.0 ) .AND. (KEEP(48).NE.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_71 :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) ENDIF CALL CMUMPS_79( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE ) THEN IERR = -1 RETURN END IF DO IDEST= 1, NDEST CALL MUMPS_49( & 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF ( MYID .NE. DEST( IDEST ) ) THEN CALL CMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST(IDEST) & ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Problem in CMUMPS_4: IERR<0' CALL MUMPS_ABORT() END IF IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 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 ) = TROW_SIZE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF (( NSLAVES.GT.0 ) .AND. (KEEP(48).NE.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 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_71 SUBROUTINE CMUMPS_65( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL, & PDEST, NDEST, KEEP50, NB_BLOC_FAC, COMM, IERR ) IMPLICIT NONE INTEGER INODE, NCOL, NPIV, FPERE, NFRONT, NDEST INTEGER IPIV( NPIV ) COMPLEX VAL( NFRONT, * ) INTEGER PDEST( NDEST ) INTEGER KEEP50, NB_BLOC_FAC, COMM, IERR LOGICAL LASTBL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE, & IDEST, IPOSMSG, I INTEGER NPIVSENT INTEGER SSS, SS2 IERR = 0 IF ( LASTBL ) THEN IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF ELSE IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF END IF SIZE2 = 0 IF (NPIV.GT.0) & CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_COMPLEX, & COMM, SIZE2, IERR ) SIZE = SIZE1 + SIZE2 CALL CMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & NDEST , PDEST & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES) THEN SSS = 0 IF ( LASTBL ) THEN IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) END IF ELSE IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) END IF END IF IF (NPIV.GT.0) & CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_COMPLEX, & COMM, SS2, IERR ) SSS = SSS + SS2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF 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 ), SIZE, & POSITION, COMM, IERR ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) IF ( LASTBL .or. KEEP50.ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END IF IF ( LASTBL .AND. KEEP50 .NE. 0 ) THEN CALL MPI_PACK( NDEST, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) IF ( NPIV.GT.0) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NCOL, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END DO ENDIF DO IDEST = 1, NDEST IF ( KEEP50.eq.0) THEN CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR ) ELSE CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR ) END IF END DO SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL CMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_65 SUBROUTINE CMUMPS_64( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU, & NDEST, PDEST, COMM, IERR ) IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE COMPLEX UIP21K( NPIV, NCOLU ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE, & IDEST, IPOSMSG, SSS, SS2 IERR = 0 CALL MPI_PACK_SIZE( 6 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_COMPLEX, & COMM, SIZE2, IERR ) SIZE = SIZE1 + SIZE2 IF (SIZE.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR ) CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_COMPLEX, & COMM, SS2, IERR ) SSS = SSS+SS2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF CALL CMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, 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 ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( UIP21K, abs(NPIV) * NCOLU, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) DO IDEST = 1, NDEST 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 SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL CMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_64 SUBROUTINE CMUMPS_648( 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_79( 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 CALL CMUMPS_4( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF 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 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 id%INFO(1)=-3 id%INFO(2)=JOB ENDIF ENDIF CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR) CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) THEN IF (id%KEEP(201).GT.0) THEN CALL CMUMPS_587(id, IERR) ENDIF GOTO 499 ENDIF CALL CMUMPS_163( id ) GOTO 500 END IF IF ( JOB .EQ. -2 ) THEN id%KEEP(40)= -2 - 456789 CALL CMUMPS_136( id ) GOTO 500 END IF IF ((JOB.LT.1).OR.(JOB.GT.6)) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF (id%MYID.EQ.MASTER) THEN IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN IF ((N.LE.0).OR.((N+N+N)/3.NE.N)) THEN id%INFO(1) = -16 id%INFO(2) = N END IF IF (id%ICNTL(5).NE.1) THEN IF (NZ.LE.0) THEN id%INFO(1) = -2 id%INFO(2) = NZ END IF ELSE IF (NELT.LE.0) THEN id%INFO(1) = -24 id%INFO(2) = NELT END IF ENDIF END IF IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF END IF CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 LANAL = .FALSE. LFACTO = .FALSE. LSOLVE = .FALSE. IF ((JOB.EQ.1).OR.(JOB.EQ.4).OR. & (JOB.EQ.6)) LANAL = .TRUE. IF ((JOB.EQ.2).OR.(JOB.EQ.4).OR. & (JOB.EQ.5).OR.(JOB.EQ.6)) LFACTO = .TRUE. IF ((JOB.EQ.3).OR.(JOB.EQ.5).OR. & (JOB.EQ.6)) LSOLVE = .TRUE. IF (MP.GT.0) CALL CMUMPS_349(id, MP) OLDJOB = id%KEEP( 40 ) + 456789 IF ( LANAL ) THEN 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 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 IF ( OLDJOB .LT. 1 .and. .NOT. LANAL ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF IF ( LSOLVE ) THEN IF ( OLDJOB .LT. 2 .AND. .NOT. LFACTO ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF #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 id%INFO(1)=-13 id%INFO(2)=id%N IF (id%ICNTL(1) .GT. 0 .AND. id%ICNTL(4) .GE.1) THEN WRITE(id%ICNTL(2),99993) END IF GOTO 510 ENDIF DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I END DO DO I = 1, id%NZ J = id%JCN(I) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I)=UNS_PERM_INV(J) END DO DEALLOCATE(UNS_PERM_INV) END IF END IF #endif CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 IF (LANAL) THEN id%KEEP(40)=-1 -456789 IF (id%MYID.EQ.MASTER) THEN id%INFOG(7) = -9999 id%INFOG(23) = 0 id%INFOG(24) = 1 IF (associated(id%IS1)) DEALLOCATE(id%IS1) IF ( id%ICNTL(5) .NE. 1 ) THEN 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 = 11 * N ELSE id%MAXIS1 = 10 * N END IF ELSE id%MAXIS1 = 6 * N + 2 * NELT + 2 ENDIF ALLOCATE( id%IS1(id%MAXIS1), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%MAXIS1 IF ( LP .GT.0 ) & WRITE(LP,*) 'Problem in allocating work array for analysis.' GO TO 100 END IF 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 ( LP .GT. 0 ) THEN WRITE(LP,*) 'Problem in allocating work array PROCNODE' END IF GOTO 100 END IF id%PROCNODE(1:id%N) = 0 IF ( id%ICNTL(5) .EQ. 1 ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP,*) 'Problem in allocating work array ELTPROC' END IF GOTO 100 END IF END IF IF ( id%ICNTL(5) .NE. 1 ) THEN id%NA_ELT=0 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 ELSE IF ( size( id%IRN ) < id%NZ ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE IF ( size( id%JCN ) < id%NZ ) THEN id%INFO(1) = -22 id%INFO(2) = 2 END IF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF (LP.GT.0) WRITE(LP,*) & '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 id%NA_ELT = 0 IF ( id%KEEP(50) .EQ. 0 ) THEN DO I = 1,NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) J = (J * J) id%NA_ELT = id%NA_ELT + J ENDDO ELSE DO I = 1,NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) J = (J * (J+1))/2 id%NA_ELT = id%NA_ELT + J ENDDO ENDIF ENDIF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF (LP.GT.0) WRITE(LP,*) & 'Error in analysis: ELTPTR/ELTVAR badly allocated.' END IF ENDIF 100 CONTINUE END IF CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(52) = id%ICNTL(8) IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 CALL CMUMPS_26( id ) 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 IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF IF (LFACTO) THEN id%KEEP(40) = 1 - 456789 IF ( id%MYID .EQ. MASTER ) THEN IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN id%SCHUR=>id%SCHUR_CINTERFACE & (1:id%SIZE_SCHUR*id%SIZE_SCHUR) 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 IF ( id%KEEP(55) .EQ. 0 ) THEN IF ( id%KEEP(54).eq.0 ) THEN IF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE IF ( size( id%A ) < id%NZ ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF END IF ELSE IF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE IF ( size( id%A_ELT ) < id%NA_ELT ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF CALL MUMPS_633(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) CALL CMUMPS_635(N,id%KEEP(1),id%ICNTL(1),MPG) 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.77) THEN IF (id%KEEP(50).EQ.1) THEN id%KEEP(52) = 0 ELSE 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 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 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 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 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 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 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 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(N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 END IF 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 ( LP .GT. 0 ) & WRITE(LP,*) 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL CMUMPS_758 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) CALL CMUMPS_807(id) CALL CMUMPS_769(id) ENDIF 200 CONTINUE END IF CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( id%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN id%SCHUR=>id%SCHUR_CINTERFACE & (1:id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) ENDIF 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 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 CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL CMUMPS_142(id) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) 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 IF ( id%INFO(1) .LT. 0 ) GO TO 499 id%KEEP(40) = 2 - 456789 END IF IF (LSOLVE) THEN id%KEEP(40) = 2 -456789 IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 ENDIF CALL CMUMPS_301(id) IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 id%KEEP(40) = 3 -456789 ENDIF IF (MP.GT.0) CALL CMUMPS_349(id, MP) GOTO 500 499 PROK = ((id%ICNTL(1).GT.0).AND. & (id%ICNTL(4).GE.1)) IF (PROK) WRITE (id%ICNTL(1),99995) id%INFO(1) IF (PROK) WRITE (id%ICNTL(1),99994) id%INFO(2) 500 CONTINUE #if ! defined(LARGEMATRICES) IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN IF (id%JOB .NE. 3 .OR. UNS_PERM_DONE) THEN DO I = 1, id%NZ J=id%JCN(I) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I)=id%UNS_PERM(J) END DO END IF END IF #endif 510 CONTINUE CALL CMUMPS_300(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) CALL MPI_BCAST( id%RINFOG(1), 40, MPI_REAL, MASTER, & id%COMM, IERR ) IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I12)') ' On return from CMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I12)') ' On return from CMUMPS, INFOG(2)=', & id%INFOG(2) END IF CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE RETURN 99995 FORMAT (' ** ERROR RETURN ** FROM CMUMPS INFO(1)=', I3) 99994 FORMAT (' ** INFO(2)=', I10) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE CMUMPS SUBROUTINE CMUMPS_300( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INFO(40), INFOG(40), COMM, MYID INTEGER TMP1(2),TMP(2) INTEGER ROOT, IERR INTEGER MASTER PARAMETER (MASTER=0) IF ( INFO(1) .ge. 0 .and. INFO(2) .ge. 0 ) THEN INFOG(1) = INFO(1) INFOG(2) = INFO(2) ELSE INFOG(1) = INFO(1) 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 CALL MPI_BCAST(INFOG(3), 38, MPI_INTEGER, MASTER, COMM, IERR ) RETURN END SUBROUTINE CMUMPS_300 SUBROUTINE CMUMPS_349(id, LP) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LT.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) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SHUR) =',I10) END SUBROUTINE CMUMPS_349 SUBROUTINE CMUMPS_350(id, LP) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LT.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_350 SUBROUTINE CMUMPS_758 & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE 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_758 SUBROUTINE CMUMPS_807(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE 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_807 SUBROUTINE CMUMPS_769(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE 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 RETURN END SUBROUTINE CMUMPS_769 SUBROUTINE CMUMPS_24( 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 ), & 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_330, MUMPS_275, MUMPS_810 EXTERNAL MUMPS_330, MUMPS_275, MUMPS_810 INTEGER ISTEP, I, IPTRI, IPTRR, NCOL, NROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) KEEP(14) = 0 KEEP(13) = 0 DO I = 1, N ISTEP=abs(STEP(I)) ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_810 ( 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. 1.OR.ITYPE.EQ.2) .AND. & IRANK .EQ. MYID ) & .OR. & ( T4_MASTER_CONCERNED ) & ) THEN KEEP( 14 ) = KEEP( 14 ) + 3 + PTRAIW( I ) + PTRARW( I ) KEEP( 13 ) = KEEP( 13 ) + 1 + PTRAIW( I ) + PTRARW( I ) ELSE IF ( ITYPE .EQ. 3 ) THEN ELSE IF ( ITYPE .EQ. 2 .AND. I_AM_CAND_LOC ) THEN PTRARW( I ) = 0 KEEP(14) = KEEP(14) + 3 + PTRAIW( I ) + PTRARW( I ) KEEP(13) = KEEP(13) + 1 + PTRAIW( I ) + PTRARW( I ) END IF END DO IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( KEEP(14) > 0 ) THEN ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = KEEP(14) 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 IPTRR = 1 DO I = 1, N ISTEP = abs(STEP(I)) ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_810 ( 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 = PTRAIW( I ) NROW = PTRARW( I ) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + NCOL + NROW + 3 IPTRR = IPTRR + NCOL + NROW + 1 ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NCOL = 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 + NCOL + NROW + 3 IPTRR = IPTRR + NCOL + NROW + 1 ELSE PTRAIW(I) = 0 PTRARW(I) = 0 END IF END DO IF ( IPTRI - 1 .NE. KEEP(14) ) THEN WRITE(*,*) 'Error 1 in anal_arrowheads', & ' IPTRI - 1, KEEP(14)=', IPTRI - 1, KEEP(14) CALL MUMPS_ABORT() END IF IF ( IPTRR - 1 .NE. KEEP(13) ) THEN WRITE(*,*) 'Error 2 in anal_arrowheads' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE CMUMPS_24 SUBROUTINE CMUMPS_148(N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & LP, COMM, root, KEEP, KEEP8, FILS, RG2L, & INTARR, DBLARR, PTRAIW, PTRARW, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES ) IMPLICIT NONE INCLUDE 'cmumps_root.h' INTEGER N,NZ, COMM, NBRECORDS 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) :: LA INTEGER PTRAIW( N ), PTRARW( N ), FRERE_STEPS( KEEP(28) ) INTEGER STEP(N) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX A( LA ), DBLARR(max(1,KEEP(13))) INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI COMPLEX, DIMENSION(:,:), ALLOCATABLE :: BUFR INTEGER MUMPS_275, MUMPS_330, numroc, & MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, numroc, & MUMPS_810 COMPLEX VAL INTEGER IOLD,JOLD,INEW,JNEW,ISEND,JSEND,DEST,I,K,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 I1, IA, JARR, ILOCROOT, JLOCROOT INTEGER IS1, ISHIFT, IIW, IS, IAS INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 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_330( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE = MUMPS_275( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_810( PROCNODE_STEPS(ISTEP), & SLAVEF ) I_AM_CAND_LOC = .FALSE. 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 = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL END IF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 ) & .AND. IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF (MUMPS_275( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) == MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL CMUMPS_310( 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 DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) & CALL CMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN CALL CMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN CALL CMUMPS_34( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( DEST .GT. 0 ) THEN CALL CMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) IF ( T4MASTER.GT.0 ) THEN CALL CMUMPS_34( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN CALL CMUMPS_34( 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_18( & 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_148 SUBROUTINE CMUMPS_34(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_34 SUBROUTINE CMUMPS_18( & 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_18 RECURSIVE SUBROUTINE CMUMPS_310( 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_310(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL CMUMPS_310(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE CMUMPS_310 SUBROUTINE CMUMPS_145( 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, LDBLARR, LINTARR, & COMM INTEGER INTARR(LINTARR) INTEGER 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) 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, IA, I1, I, allocok INTEGER IS, IS1, ISHIFT, IIW, IAS INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 COMPLEX VAL COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR 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 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 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_330( 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 IA = PTRARW(IARR) DBLARR(IA) = DBLARR(IA) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL ENDIF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) & .AND. IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_275( 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_310( 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_145 SUBROUTINE CMUMPS_266( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & TNBPROCFILS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, ITLOC, RHS_MUMPS, & IFLAG, IERROR ) USE CMUMPS_LOAD IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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 COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_RECU, NFRONT INTEGER LREQ INTEGER(8) :: LREQCB DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' INODE = BUFR( 1 ) NBPROCFILS = BUFR( 2 ) NROW = BUFR( 3 ) NCOL = BUFR( 4 ) NASS = BUFR( 5 ) NFRONT = BUFR( 6 ) NSLAVES_RECU = BUFR( 7 ) 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_190(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_22(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP,KEEP8, 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 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( 8 + NSLAVES_RECU : 7 + NSLAVES_RECU + NROW + NCOL ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_RECU.GT.0) & IW( IWPOSCB + 7+XTRA_SLAVES_UNSYM+KEEP(IXSZ): & IWPOSCB+6+KEEP(IXSZ)+NSLAVES_RECU ) = & BUFR( 8: 7 + NSLAVES_RECU ) ELSE IW( IWPOSCB + 7+KEEP(IXSZ) ) = 0 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( 8: 7 + NSLAVES_RECU ) END IF TNBPROCFILS(STEP( INODE )) = NBPROCFILS RETURN END SUBROUTINE CMUMPS_266 SUBROUTINE CMUMPS_163( id ) USE CMUMPS_STRUC_DEF USE CMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC) id INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) PAR_loc=id%PAR SYM_loc=id%SYM CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( PAR_loc .eq. 0 ) THEN 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 CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF CALL CMUMPS_20( 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%WRITE_PROBLEM="NAME_NOT_INITIALIZED" CALL MUMPS_SET_VERSION( id%VERSION_NUMBER ) id%OOC_TMPDIR="NAME_NOT_INITIALIZED" id%OOC_PREFIX="NAME_NOT_INITIALIZED" id%NRHS = 1 id%LRHS = 0 id%LREDRHS = 0 CALL CMUMPS_61( id%KEEP( 34 ), id%KEEP(35) ) NULLIFY(id%BUFR) id%MAXIS1 = 0 id%INST_Number = -1 id%N = 0; id%NZ = 0 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0 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) 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%POIDS) 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%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) 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%CB_SON_SIZE) 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) id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 id%SCHUR_NLOC = 0 id%SCHUR_LLD = 0 NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) CALL CMUMPS_637(id) NULLIFY(id%MEM_DIST) NULLIFY(id%SUP_PROC) id%Deficiency = 0 id%root%LPIV = -1 id%root%yes = .FALSE. id%root%gridinit_done = .FALSE. 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_163 SUBROUTINE CMUMPS_252( COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & & 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 & ) USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR TYPE (CMUMPS_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) INTEGER IFLAG,IERROR,INODE,MAXFRW, & IWPOS, IWPOSCB, COMP INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 COMPLEX A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)) INTEGER NSTK_S(KEEP(28)),PROCNODE_STEPS(KEEP(28)) INTEGER IPOOL( LPOOL ) INTEGER BUFR( LBUFR ) INTEGER IDUMMY(1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(N), PTRAIW(N), ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) COMPLEX :: 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 INTARR(max(1,KEEP(14))) COMPLEX DBLARR(max(1,KEEP(13))) INTEGER MUMPS_330 EXTERNAL MUMPS_330 INTEGER LP, HS, HF 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) :: SIZFR INTEGER SIZFI, NCB INTEGER J1,J2 INTEGER NCOLS, NROWS, LDA_SON INTEGER(8) :: JJ2, ICT13 #if defined(ALLOW_NON_INIT) INTEGER(8) :: NUMROWS, JJ3, JJ8, APOS_ini #endif INTEGER NELIM,JJ,JJ1,J3, & IBROT,IORG INTEGER JPOS,ICT11 INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4 INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER AINPUT 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 INCLUDE 'mumps_headers.h' INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_167 LOGICAL MUMPS_167 LOGICAL SSARBR LOGICAL COMPRESSCB INTEGER(8) :: LCB DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_170 LOGICAL MUMPS_170 COMPRESSCB =.FALSE. NELT = 1 LPTRAR = N NFS4FATHER = -1 IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (LEVEL.NE.1) THEN write(6,*) 'Error1 in mpi51f_niv1 ' CALL MUMPS_ABORT() ENDIF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_167(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) ENDDO 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 NASS = NASS + IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG LREQ_OOC = 0 IF (KEEP(201).EQ.1) THEN CALL CMUMPS_684( 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF 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_330(PROCNODE_STEPS(STEP(ISON)),SLAVEF) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_729(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. IF (KEEP(50).EQ.0 .AND. KEEP(234) .EQ. 0) THEN CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, & NFRONT_EFF, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, & PROCNODE_STEPS, SLAVEF ) ELSE CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF) IF (IFLAG.LT.0) GOTO 300 ENDIF IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_170(PROCNODE_STEPS(STEP(INODE)), & SLAVEF))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL CMUMPS_190(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 Write(*,*) ' ERROR 1 during ass_niv1', NFRONT, NFRONT_EFF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL CMUMPS_691(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 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 GOTO 280 ELSE CALL CMUMPS_94 & (N, KEEP(28), IW, LIW, A, LA, LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER,KEEP(216),LRLUS,KEEP(IXSZ)) COMP = COMP + 1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL CMUMPS_471(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLU) #if ! defined(ALLOW_NON_INIT) 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) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO ELSE IF (ETATASS.EQ.1) THEN APOS_ini = POSELT DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8,int(NASS1-1,8)) APOS = APOS_ini + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO ELSE APOS_ini = POSELT NUMROWS = min(NFRONT8, (IPTRLU-APOS_ini) / NFRONT8 ) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = APOS_ini + JJ8 * NFRONT8 A(APOS:APOS + JJ8) = ZERO ENDDO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = APOS_ini + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST_S(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 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)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) 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.LE.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS J1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1) THEN J2 = J1 + LSTK - 1 SIZFR = int(LSTK,8)*int(LSTK,8) IF (COMPRESSCB) SIZFR = (int(LSTK,8)*int(LSTK+1,8))/2_8 ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR = int(NELIM,8) * int(LSTK,8) ELSE SIZFR = int(NELIM,8) * int(NELIM,8) END IF J2 = J1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) OPASSW = OPASSW + dble(SIZFR) 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 + SIZFR - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (J2.GE.J1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC) RISK_OF_SAME_POS = IACHK + SIZFR - 1_8 .EQ. POSFAC - 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. & ((J2-J1).GT.300) DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * int(NFRONT,8) IACHK = IACHK_ini + int(JJ-J1,8)*int(LSTK,8) IF (RISK_OF_SAME_POS) THEN IF (JJ.EQ.J2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(IW(J1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(JJ>J1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) IF ( IACHK+int(JJ1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(JJ1 - 1,8)) A(IACHK + int(JJ1 -1,8)) = ZERO ENDIF ENDDO ELSE DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 A(JJ2) = A(IACHK + int(JJ1 - 1,8)) A(IACHK + int(JJ1 -1,8)) = ZERO ENDDO ENDIF ELSE DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 1,8)) ENDDO ENDIF 170 CONTINUE END IF ELSE IF (LEVEL1) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR ELSE LCB = int(LDA_SON,8)* int(J2-J1+1,8) ENDIF CALL CMUMPS_178(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), J2 - J1 + 1, NELIM, ETATASS, & COMPRESSCB, (ISON.EQ.ISON_IN_PLACE) & ) 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 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 J3 = J3 - 1 DO JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = 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_152(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_49( & 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_210( 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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .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_71( & 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_329( & 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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 JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) IJROW = INTARR(J1) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) Cduplicates --> CVD$ DEPCHK DO 240 JJ = J1, J2 APOS2 = ICT12 + int(INTARR(JJ),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + 1 240 CONTINUE IF (J3 .LE. J4) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = J4 - J3 + 1 Cduplicates--> CVD$ DEPCHK CduplicatesCVD$ NODEPCHK DO 250 JJ = 1, NBCOL APOS3 = ICT13 + int(INTARR(J3 + JJ - 1) - 1,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT + JJ - 1) 250 CONTINUE ENDIF IF (KEEP(50).EQ.0) THEN DO JJ=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ELSE DO JJ=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+JJ-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE GOTO 500 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_252' ENDIF GOTO 490 280 CONTINUE IFLAG = -9 CALL MUMPS_731(LAELL_REQ8 - LRLUS, IERROR) IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING CMUMPS_252' ENDIF 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 DURING CMUMPS_252' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING CMUMPS_252' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING CMUMPS_252' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 490 CALL CMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_252 SUBROUTINE CMUMPS_253(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM , MEM_DISTRIB) USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER IFLAG,IERROR,INODE,MAXFRW, & LPOOL, LEAF, IWPOS, IWPOSCB, COMP INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC COMPLEX A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, SLAVEF, 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 IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(N), PTRAIW(N), ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 INTARR(max(1,KEEP(14))) COMPLEX DBLARR(max(1,KEEP(13))) INTEGER LP, HS, HF, HF_OLD,NCBSON, NSLAVES_OLD, & NBSPLIT INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER,I INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER NCB INTEGER J1,J2,J3,MP INTEGER(8) :: JJ8, LAPOS2, JJ2, JJ3 INTEGER NELIM,JJ,JJ1,NPIVS,NCOLS,NROWS, & IBROT,IORG INTEGER LDAFS, LDA_SON INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4, NUMORG_SPLIT INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 INTEGER AINPUT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, ISLAVE, PDEST INTEGER PDEST1(1) INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6 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_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 COMPLEX ZERO REAL RZERO PARAMETER(RZERO = 0.0E0 ) PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER NELT, LPTRAR, NCBSON_MAX logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER (8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok, & NCB_SPLIT, SIZE_LIST_SPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER NBPANELS_L, NBPANELS_U MP = ICNTL(2) 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_330(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) .EQ. 1) THEN NCBSON_MAX = max & ( & IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)), NCBSON_MAX & ) 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 IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) SIZE_TMP_SLAVES_LIST = CAND( SLAVEF+1, INIV2 ) ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), & SLAVEF) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) 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 265 ENDIF CALL CMUMPS_791 ( & 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_472( 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_790 ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) TMP_SLAVES_LIST (1:SIZE_TMP_SLAVES_LIST) & = CAND (1:SIZE_TMP_SLAVES_LIST, INIV2) CALL CMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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_472( 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_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. IF (KEEP(50).EQ.0 .AND. KEEP(234).EQ.0) THEN CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, & NFRONT_EFF, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & PROCNODE_STEPS, SLAVEF ) ELSE ISON_IN_PLACE = -9999 CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF) IF (IFLAG.LT.0) GOTO 250 ENDIF 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 plitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF 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 WRITE(6,*) ' Internal error 2 in fac_ass due', & ' to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF CALL MUMPS_ABORT() ELSE CALL CMUMPS_472( 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 JJ=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+JJ)=IW(IOLDPS+HF_OLD+JJ) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO JJ=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+JJ) = IW(IOLDPS+HF_OLD+JJ) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE Write(*,*) MYID,': ERROR 2 during ass_niv2, INODE=', INODE, & ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL CMUMPS_691(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST_S(STEP(INODE)) = IOLDPS 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+KEEP(IXSZ)) = NFRONT 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_461(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_533(SLAVEF,CAND(SLAVEF+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_533(SLAVEF,SLAVEF-1, & 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 CALL CMUMPS_471(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLU) POSEL1 = POSELT - int(LDAFS,8) #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, int(LDAFS-1,8) A(APOS:APOS+JJ8) = ZERO APOS = APOS + int(LDAFS,8) END DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN A(APOS:APOS+int(LDAFS,8)-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 + 1+KEEP(IXSZ)) 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.LE.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 + 2+KEEP(IXSZ)) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) J1 = ISTCHK + HS + NROWS + NPIVS J2 = J1 + 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 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * int(LDAFS,8) DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 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 CALL CMUMPS_178( A, LA, & POSELT, LDAFS, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), NELIM, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) DO 260 IORG = 1, NUMORG JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) IJROW = INTARR(J1) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO CduplicatesCVD$ NODEPCHK DO 240 JJ = J1, J2 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT))) ENDIF ELSE IF (INTARR(JJ).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) ENDIF ENDIF AINPUT = AINPUT + 1 240 CONTINUE IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = cmplx(MAXARR,kind=kind(A)) ENDIF IF (J3 .GT. J4) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = J4 - J3 + 1 CduplicatesCVD$ NODEPCHK CduplicatesCVD$ NODEPCHK DO JJ = 1, NBCOL JJ3 = ICT13 + int(INTARR(J3 + JJ - 1),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT + JJ - 1) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO JJ = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & 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_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & IW(PDEST), NFRONT, COMM, IERR) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL CMUMPS_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & IW(PDEST), NFRONT, COMM, IERR) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST_S(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 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.LE.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) THEN IF(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 ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) IF (PDEST1(1).EQ.MYID) THEN CALL CMUMPS_211( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON))+HS+NROWS+NPIVS+NELIM CALL CMUMPS_71( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST_S(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_329( 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, ND, FRERE, LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_49( & 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_210( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .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_71( & INODE, NFRONT,NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST_S(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_329( 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & CMUMPS_253' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 GOTO 490 265 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING CMUMPS_253' ENDIF IFLAG = -13 IERROR = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_253' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING CMUMPS_253' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8-LRLUS, IERROR) 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_253' ENDIF IFLAG = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) 490 CALL CMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_253 SUBROUTINE CMUMPS_39(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_39 SUBROUTINE CMUMPS_539 & (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), PTRARW(N), PTRAIW(N) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) COMPLEX A(LA), & DBLARR(max(1,KEEP(13))) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSELT, ICT12, APOS INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS,JJ, & IN,AINPUT,JK,J1,J2,IJROW, ILOC INTEGER :: K1RHS, K2RHS, JFirstRHS 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 A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = & ZERO 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) AINPUT = PTRARW(IN) JK = PTRAIW(IN) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) IJROW = -ITLOC(INTARR(J1)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ= J1,J2 ILOC = ITLOC(INTARR(JJ)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT) ENDIF AINPUT = AINPUT + 1 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO 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_539 SUBROUTINE CMUMPS_531 & (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_531 SUBROUTINE CMUMPS_40(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 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 write(6,*) ' .. exit for col =', J 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_40 SUBROUTINE CMUMPS_178( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED, IS_INPLACE & ) 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, IS_INPLACE COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE, OMP_FLAG INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IF ( IS_INPLACE ) THEN 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 ENDIF 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN OMP_FLAG = (NROWS-NELIM).GE.300 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) .AND. .NOT. IS_INPLACE) 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) + & A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 END DO ENDIF END 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_178 SUBROUTINE CMUMPS_530(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_530 SUBROUTINE CMUMPS_619( & 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(abs(A(JJ2)) .LT. VALSON(JJ1)) & A(JJ2) = cmplx(VALSON(JJ1),kind=kind(A)) ENDDO RETURN END SUBROUTINE CMUMPS_619 RECURSIVE SUBROUTINE CMUMPS_264( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE CMUMPS_OOC USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 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 PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX DBLARR(max(1,KEEP(13))) 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 ) INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL INTEGER(8) :: POSBLOCFACTO 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 MUMPS_275 EXTERNAL MUMPS_275 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 ) LAELL = int(NPIV,8) * int(NCOL,8) IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_731(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_264" ENDIF GOTO 700 END IF CALL CMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731( 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_264" 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)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL CMUMPS_471(.FALSE., .FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, & MPI_COMPLEX, & COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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)) 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 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 LPOS2 = POSELT + int(NPIV1,8) CALL ctrsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), NCOL, A(LPOS2), NCOL1) LPOS1 = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) ENDIF 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 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL CMUMPS_688( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( NPIV .GT. 0 ) THEN CALL cgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,A(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 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. LASTBL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) ' ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) IWPOS = IWPOS - NPIV 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_190( 1, .FALSE., FLOP1, KEEP,KEEP8 ) IF (LASTBL) THEN CALL CMUMPS_759( & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE CMUMPS_264 SUBROUTINE CMUMPS_699( 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_S, 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, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE CMUMPS_LOAD USE CMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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_S( KEEP(28) ) INTEGER NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) COMPLEX A( LA ) 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX DBLARR( max( 1,KEEP(13)) ) 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 STATUS( MPI_STATUS_SIZE ) INTEGER MUMPS_275, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_810 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 BLOCKING, SET_IRECV, MESSAGE_RECEIVED, IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT 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_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_810(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) DO WHILE ( PTRIST( STEP(INODE) ) .EQ. 0 ) MASTER = MUMPS_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MASTER, MAITRE_DESC_BANDE, & STATUS, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF (IFLAG.LT.0) RETURN END DO 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_731( LREQA - LRLUS, IERROR ) CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF CALL CMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..process_contrib' WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 CALL MUMPS_731( LREQA - LRLUS, IERROR ) CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF END IF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) 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))-1 ENDIF IF ( KEEP(55) .eq. 0 ) THEN CALL CMUMPS_539 & (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_123( & 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_40(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_531 & (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_39(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST_S, 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_617(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_REAL, & COMM, IERR ) CALL CMUMPS_619(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - 1 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK .LT. IWPOSCB IF (SAME_PROC) THEN CALL CMUMPS_530(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, 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_152(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN CALL CMUMPS_507( 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_500( & 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 POSFAC = POSFAC - LREQA CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) RETURN END SUBROUTINE CMUMPS_699 SUBROUTINE CMUMPS_143( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, UU, NOFFW, & NPVW, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS ) USE CMUMPS_OOC IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, 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(30) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK INTEGER NASS, NEL1, NPIVB, NPIVE, NBOLKJ, NBTLKJ REAL UUTEMP INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INCLUDE 'mumps_headers.h' EXTERNAL MUMPS_330, CMUMPS_221, CMUMPS_233, & CMUMPS_229, & CMUMPS_225, CMUMPS_232, CMUMPS_231, & CMUMPS_220, & CMUMPS_228, CMUMPS_236 INTEGER MUMPS_330 LOGICAL STATICMODE REAL SEUIL_LOC 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 IBEG_BLOCK=1 NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IF (KEEP(201).EQ.1) THEN CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_BOTH_LU 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 50 CONTINUE CALL CMUMPS_221(NFRONT,NASS,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) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF GOTO 80 ENDIF IF (INOPV.EQ.2) THEN CALL CMUMPS_233(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP(IXSZ)) GOTO 50 ENDIF NPVW = NPVW + 1 IF (NASS.LE.1) THEN CALL CMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 GO TO 500 ENDIF CALL CMUMPS_225(IBEG_BLOCK,NFRONT, NASS, N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 50 IF (KEEP(201).EQ.1) THEN MonBloc%LastPiv= IW(IOLDPS+1+KEEP(IXSZ)) STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_U LAST_CALL = .FALSE. CALL CMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC ENDIF IF (IFINB.EQ.(-1)) GOTO 80 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV CALL CMUMPS_232(A,LA, & NFRONT,NPIV,NASS,POSELT,NBTLKJ) GO TO 50 80 CONTINUE NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IF (NPIV.LE.0) GO TO 110 NEL1 = NFRONT - NASS IF (NEL1.LE.0) GO TO 110 IF (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_BOTH_LU MonBloc%LastPiv= NPIV CALL CMUMPS_642(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_231(A,LA,NFRONT, NPIV,NASS,POSELT) ENDIF 110 CONTINUE IF (MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) & .EQ.1) THEN NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 120 CALL CMUMPS_220(NFRONT,NASS,N,INODE,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) IF (INOPV.NE.1) THEN NPVW = NPVW + 1 CALL CMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVB = IBEG_BLOCK NPIVE = NPIV - NPIVB NEL1 = NFRONT - NASS IF ((NPIVE.LE.0).OR.(NEL1.EQ.0)) GO TO 500 CALL CMUMPS_236(A,LA,NPIVB, & NFRONT,NPIV,NASS,POSELT) ENDIF 500 CONTINUE IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) TYPEFile = TYPEF_BOTH_LU LAST_CALL = .TRUE. CALL CMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC CALL CMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE CMUMPS_143 RECURSIVE SUBROUTINE CMUMPS_322( & 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) 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) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(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 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 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( max(1,KEEP(14)) ) COMPLEX DBLARR( max(1,KEEP(13)) ) INTEGER INIV2, ISHIFT, IBEG INTEGER MUMPS_275 EXTERNAL MUMPS_275 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 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) CHARACTER(LEN=35)::SUBNAME MP = ICNTL(2) LP = ICNTL(1) SUBNAME="??????" CALL CMUMPS_467(COMM_LOAD, KEEP) 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_269( MYID,KEEP,KEEP8, & 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_269" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL CMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL CMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_500( & 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_266( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, NBPROCFILS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, ITLOC, RHS_MUMPS, & IFLAG, IERROR ) SUBNAME="CMUMPS_266" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL CMUMPS_268(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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & KEEP,KEEP8, ND, FILS, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="CMUMPS_268" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO ) THEN CALL CMUMPS_264( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL CMUMPS_263( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL CMUMPS_274( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL CMUMPS_699( 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_S, 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, IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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).AND.(KEEP(48).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_210( 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_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL CMUMPS_700( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF) SUBNAME="CMUMPS_700" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(IROOT)), & SLAVEF ) IF ( PTLUST_S( STEP(IROOT)) .EQ. 0 ) THEN CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL CMUMPS_270( TMP( 1 ), TMP( 2 ), & 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, ND ) SUBNAME="CMUMPS_270" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL CMUMPS_700( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF ) SUBNAME="CMUMPS_700" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL CMUMPS_271( 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GO TO 100 IF (MYID.NE.MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF)) THEN IF (KEEP(50).EQ.0) THEN IF (IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)) = S_ROOT2SON_CALLED ELSE CALL CMUMPS_626( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ELSE IF (IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)) = S_ROOT2SON_CALLED ELSE CALL CMUMPS_626( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL CMUMPS_270( 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_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, 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_273( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, KEEP,KEEP8, & COMM, COMM_LOAD, FILS, ND) SUBNAME="CMUMPS_273" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in CMUMPS_322" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine CMUMPS_322.',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_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE CMUMPS_322 RECURSIVE SUBROUTINE CMUMPS_280( & COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) 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) 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(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(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 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 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( max(1,KEEP(14)) ) COMPLEX DBLARR( max(1,KEEP(13)) ) 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_44( MYID, SLAVEF, COMM ) RETURN ENDIF CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL CMUMPS_322( & 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) RETURN END SUBROUTINE CMUMPS_280 RECURSIVE SUBROUTINE CMUMPS_329( & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED ) 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) 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(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 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 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( max(1,KEEP(14)) ) COMPLEX DBLARR( max(1,KEEP(13)) ) 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_467(COMM_LOAD, KEEP) 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 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_329' CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF IF ( FLAG ) THEN 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_322( 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_280( COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_280( COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_329 SUBROUTINE CMUMPS_255( INFO1, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE CMUMPS_COMM_BUFFER 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 STATUS( MPI_STATUS_SIZE ) LOGICAL NO_ACTIVE_IRECV INTEGER MSGSOU_LOC, MSGTAG_LOC 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) ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL CMUMPS_62 & (DUMMY, DEST, TAG_DUMMY, COMM, 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 RETURN END SUBROUTINE CMUMPS_255 SUBROUTINE CMUMPS_180( & INFO1, BUFR, LBUFR, LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, MP ) USE CMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER COMM_NODES, COMM_LOAD, SLAVEF, INFO1, MP INTEGER STATUS( MPI_STATUS_SIZE ) LOGICAL FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS INTEGER MSGSOU_LOC, MSGTAG_LOC, COMM_EFF INTEGER IERR INTEGER IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS IF (SLAVEF.EQ.1) RETURN BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. 10 CONTINUE FLAG = .TRUE. DO WHILE ( FLAG ) COMM_EFF = COMM_NODES CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, & COMM_NODES, FLAG, STATUS, IERR) IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_LOAD CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM_LOAD, FLAG, STATUS, IERR) END IF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_RECV( BUFR, LBUFR_BYTES, & MPI_PACKED, MSGSOU_LOC, & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) ENDIF END DO IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN RETURN ENDIF CALL CMUMPS_469(BUFFERS_EMPTY) IF ( BUFFERS_EMPTY ) THEN IBUF_EMPTY = 0 ELSE IBUF_EMPTY = 1 ENDIF CALL MPI_ALLREDUCE(IBUF_EMPTY, & IBUF_EMPTY_ON_ALL_PROCS, & 1, MPI_INTEGER, MPI_MAX, & COMM_NODES, IERR) IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. ELSE BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. ENDIF GOTO 10 END SUBROUTINE CMUMPS_180 INTEGER FUNCTION CMUMPS_748 & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) K227_LOC = abs(K227) IF (K50.EQ.2) THEN K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) ELSE 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_748 = EFFECTIVE_SIZE RETURN END FUNCTION CMUMPS_748 SUBROUTINE CMUMPS_698( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) COMPLEX THE_PANEL(NBROW, NBCOL) INTEGER I, IPERM DO I = 1, LPIV 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_698 SUBROUTINE CMUMPS_667(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) INTEGER I_NBPANELS, I_NASS I_NASS = IPOS I_NBPANELS = I_NASS + 1 NBPANELS = IW(I_NBPANELS) I_PIVPTR = I_NBPANELS + 1 I_PIV = I_PIVPTR + NBPANELS IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) NBPANELS = IW(I_NBPANELS) I_PIVPTR = I_NBPANELS + 1 I_PIV = I_PIVPTR + NBPANELS ENDIF RETURN END SUBROUTINE CMUMPS_667 SUBROUTINE CMUMPS_691(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) INTEGER IPOS_U IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: CMUMPS_691 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_691 SUBROUTINE CMUMPS_644 ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE CMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE IF (KEEP(50).EQ.1) RETURN IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE CALL CMUMPS_667(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 CALL CMUMPS_667(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 IF (FREESPACE) THEN IW(IBEGOOC) = -7777 IW(IOLDPS+XXI) = IBEGOOC - IOLDPS + 1 IWPOS = IBEGOOC+1 ENDIF RETURN END SUBROUTINE CMUMPS_644 SUBROUTINE CMUMPS_684(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE CMUMPS_OOC IMPLICIT NONE INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF NBPANELS_L = (NASS / CMUMPS_690(NBROW_L))+1 LREQ = 1 & + 1 & + NASS & + NBPANELS_L IF (K50.eq.0) THEN NBPANELS_U = (NASS / CMUMPS_690(NBCOL_U) ) +1 LREQ = LREQ + 1 & + NASS & + NBPANELS_U ENDIF RETURN END SUBROUTINE CMUMPS_684 SUBROUTINE CMUMPS_755 & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_755 mumps-4.10.0.dfsg/src/smumps_part8.F0000644000175300017530000101656211562233065017457 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE SMUMPS_301( id) USE SMUMPS_STRUC_DEF USE MUMPS_SOL_ES USE SMUMPS_COMM_BUFFER USE SMUMPS_OOC USE TOOLS_COMMON IMPLICIT NONE INTERFACE SUBROUTINE SMUMPS_710( id, NB_INT,NB_CMPLX ) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC) :: id INTEGER(8) :: NB_INT,NB_CMPLX END SUBROUTINE SMUMPS_710 SUBROUTINE SMUMPS_758 &(idRHS, idINFO, idN, idNRHS, idLRHS) REAL, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE SMUMPS_758 END INTERFACE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE (SMUMPS_STRUC), TARGET :: id INTEGER MP,LP, MPG LOGICAL PROK, PROKG INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, ERANAL, GIVSOL INTEGER ICNTL10, ICNTL11 INTEGER I,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK INTEGER LIW INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER LWCB_MIN, LWCB, LWCB_SOL_C INTEGER(8) :: TMP_LWCB8 INTEGER SMUMPS_LBUF, SMUMPS_LBUF_INT INTEGER MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 INTEGER NITREF, NOITER, SOLVET, KASE, JOBIREF REAL RSOL(1) LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 INTEGER :: K220(0:id%NSLAVES) 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 INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, NBT INTEGER :: PERM_PIV_LIST(max(id%KEEP(112),1)) INTEGER :: MAP_PIVNUL_LIST(max(id%KEEP(112),1)) INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS REAL ONE REAL ZERO PARAMETER( ONE = 1.0E0 ) PARAMETER( ZERO = 0.0E0 ) REAL RZERO, RONE PARAMETER( RZERO = 0.0E0, RONE = 1.0E0 ) REAL, DIMENSION(:), POINTER :: RHS_MUMPS REAL, DIMENSION(:), POINTER :: WORK_WCB REAL, DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER :: LPTR_RHS_ROOT REAL, ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) REAL, ALLOCATABLE :: CWORK(:) REAL, ALLOCATABLE :: R_RW1(:), R_Y(:), D(:) REAL, ALLOCATABLE :: R_W(:) REAL, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 REAL, ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV, & POSINRHSCOMP_N INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) 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 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 REAL, DIMENSION(:), POINTER :: PT_SCALING REAL, TARGET :: Dummy_SCAL(1) 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, WHAT INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & IBEG, LD_RHS, KDEC, & MASTER_ROOT, MASTER_ROOT_IN_COMM INTEGER IPT_RHS_ROOT, SIZE_ROOT, LD_REDRHS INTEGER IBEG_REDRHS, IBEG_RHSCOMP, LD_RHSCOMP, LENRHSCOMP INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES INTEGER(8) NB_BYTES_MAX INTEGER(8) NB_BYTES_EXTRA INTEGER(8) NB_INT, NB_CMPLX, K34_8, K35_8, NB_BYTES_ON_ENTRY INTEGER(8) K16_8, ITMP8 #if defined(V_T) 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 MUMPS_275 EXTERNAL MUMPS_275 #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 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_MUMPS) 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 RINFOG =>id%RINFOG MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LP = id%ICNTL( 1 ) PROK = (MP.GT.0) PROKG = (MPG.GT.0 .and. id%MYID.eq.MASTER) 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) NB_RHSSKIPPED = 0 LSCAL = .FALSE. WORK_WCB_ALLOCATED = .FALSE. ICNTL21 = -99998 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) CALL SMUMPS_710 (id, NB_INT,NB_CMPLX ) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K35_8 NB_BYTES_ON_ENTRY = NB_BYTES NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID .EQ. MASTER) THEN CALL SMUMPS_807(id) id%KEEP(111) = id%ICNTL(25) id%KEEP(248) = id%ICNTL(20) ICNTL21 = id%ICNTL(21) IF (ICNTL21 .ne.0.and.ICNTL21.ne.1) ICNTL21=0 IF ( id%ICNTL(30) .NE.0 ) THEN id%KEEP(237) = 1 ELSE id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN id%KEEP(248)=1 ENDIF IF (id%KEEP(248) .ne.0.and.id%KEEP(248).ne.1) id%KEEP(248)=0 IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN id%KEEP(248) = 0 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN id%KEEP(235) = 0 ENDIF MTYPE = ICNTL( 9 ) 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(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 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(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF ( id%MYID .EQ. MASTER ) THEN 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 IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN 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 IF (KEEP(252).NE.0 .AND. ICNTL(9).NE.1) THEN 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 INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE INFO(2) = 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 IF ( (id%KEEP(237).EQ.0) ) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. ICNTL21==0) THEN CALL SMUMPS_758 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE 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 IF ((id%NZ_RHS.LE.0).AND.(KEEP(237).NE.0)) THEN 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 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 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 IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN IF (PROKG) THEN write(MPG,*)id%MYID, & " Incompatible values for sparse RHS ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 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 CALL SMUMPS_634(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(111) .NE. 0 .AND. id%KEEP(50) .EQ. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: null space not available for unsymmetric matrices' INFO(1) = -37 INFO(2) = 0 GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN 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 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 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 END IF IF (ICNTL21==1) THEN IF ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) THEN 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 (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 IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1) THEN 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 CALL SMUMPS_769(id) END IF IF (id%INFO(1) .LT. 0) GOTO 333 333 CONTINUE CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 IF ((id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0)) THEN CALL MPI_BCAST(id%NZ_RHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (id%NZ_RHS.EQ.0) THEN IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN LIW_PASSED=max(1,KEEP(32)) IF (KEEP(89) .GT. 0) THEN CALL SMUMPS_535( 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 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 IF ( PROKG ) THEN 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 WRITE (MPG, 153) KEEP(252) ENDIF ENDIF GOTO 90 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(111).NE.0)) THEN KEEP(242) = 0 ENDIF ENDIF INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN IF (LP.GT.0) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF NBT = 0 CALL MUMPS_733(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF (NBT.NE.0) THEN DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE id%Step2node(id%STEP(I)) = I ENDDO ENDIF NB_BYTES = NB_BYTES + int(NBT,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + int(NBT,8) * K34_8 ENDIF IF ( I_AM_SLAVE ) & CALL MUMPS_804(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 IF (id%MYID.EQ.MASTER) THEN IF( KEEP(111)==0 .AND. KEEP(248)==1 ) THEN NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) & NRHS_NONEMPTY = NRHS_NONEMPTY+1 ENDDO IF (NRHS_NONEMPTY.LE.0) THEN IF (LP.GT.0) & WRITE(LP,*) 'Internal error : NRHS_NONEMPTY=', & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF BUILD_POSINRHSCOMP = .TRUE. IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN BUILD_POSINRHSCOMP = .FALSE. ENDIF SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_275( & 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 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_275( & 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 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF IF (id%MYID .eq. MASTER) THEN KEEP(84) = ICNTL(27) IF (KEEP(252).NE.0) THEN 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 ENDIF ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (KEEP(201).GT.0) THEN IF (I_AM_SLAVE) THEN IF (KEEP(201).EQ.1 & .AND.KEEP(50).EQ.0 & .AND.KEEP(251).NE.2 & ) THEN OOC_NB_FILE_TYPE=2 ELSE OOC_NB_FILE_TYPE=1 ENDIF ENDIF 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 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 ) ENDIF IF ( I_AM_SLAVE ) THEN NB_K133 = 3 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 LWCB_MIN = NB_K133*KEEP(133)*NBRHS 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 IF (KEEP(201).EQ.0) THEN IF (ITMP8.NE.KEEP8(24)) THEN INFO(1) = -41 INFO(2) = id%LWK_USER GOTO 99 ENDIF ELSE KEEP8(24)=ITMP8 ENDIF MAXS = 0_8 IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_731(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ELSE IF (associated(id%S)) THEN MAXS = KEEP8(23) ELSE IF (KEEP(201).EQ.0) THEN WRITE(*,*) ' Working array S not allocated ', & ' on entry to solve phase (in core) ' CALL MUMPS_ABORT() ELSE IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ENDIF ALLOCATE (id%S(MAXS), stat = allocok) KEEP8(23)=MAXS IF ( allocok .GT. 0 ) THEN WRITE(*,*) ' Problem allocation of S at solve' INFO(1) = -13 CALL MUMPS_731(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) ENDIF ENDIF IF(KEEP(201).EQ.0)THEN LA = KEEP8(31) ELSE LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF IF ( MAXS-LA .GT. int(LWCB_MIN,8) ) THEN TMP_LWCB8 = min( MAXS - LA, int(huge(LWCB),8) ) LWCB = int( TMP_LWCB8, kind(LWCB) ) WORK_WCB => id%S(LA+1_8:LA+TMP_LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB = LWCB_MIN ALLOCATE(WORK_WCB(LWCB_MIN), stat = allocok) IF (allocok < 0 ) THEN INFO(1)=-13 INFO(2)=LWCB_MIN ENDIF WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(size(WORK_WCB),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF 99 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL SMUMPS_590(LA) CALL SMUMPS_586(id) IS_INIT_OOC_DONE = .TRUE. ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF (id%MYID .eq. MASTER) THEN IF ( (KEEP(242).NE.0) .or. (KEEP(243).NE.0) ) THEN IF ( (KEEP(237) .EQ.0) .and. (KEEP(111).EQ.0) ) THEN KEEP(242) = 0 KEEP(243) = 0 ENDIF ENDIF 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 WRITE (MPG, 153) KEEP(252) ENDIF ENDIF LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ERANAL = ((ICNTL(11) .GT. 0) .OR. (ICNTL(10) .GT. 0)) IF ( (KEEP(55).eq.0) .AND. KEEP(54).eq.0 .AND. & .NOT.associated(id%A) ) THEN ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. ELSE ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) ENDIF IF ((KEEP(111).NE.0).OR.(KEEP(237).NE.0).OR. & (KEEP(252).NE.0) ) THEN IF (ICNTL10 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF (ICNTL11 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. END IF IF (KEEP(221).NE.0) THEN IF (ICNTL10 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 (reduced RHS))' ENDIF IF (ICNTL11 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 (reduced RHS)' ENDIF ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. END IF IF ((ERANAL .AND. NBRHS > 1) .OR. ICNTL(21) > 0) THEN IF (ICNTL11 > 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to zero' ICNTL11=0 ENDIF IF (ICNTL10 > 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to zero' ICNTL10=0 ENDIF ERANAL = .FALSE. ENDIF IF (ERANAL) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN WRITE(*,*) ' 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 IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 END IF 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(ERANAL,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) CALL MPI_BCAST(KEEP(242),1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(243),1,MPI_INTEGER,MASTER, & id%COMM,IERR) DO_PERMUTE_RHS = (KEEP(242).NE.0) IF ( KEEP(242).NE.0) THEN IF ((KEEP(237).EQ.0).AND.(KEEP(111).EQ.0)) THEN IF (MP.GT.0) THEN write(MP,*) ' Warning incompatible options ', & ' permute RHS reset to false ' ENDIF DO_PERMUTE_RHS = .FALSE. ENDIF ENDIF IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN 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 #if defined(check) IF ( id%MYID_NODES .EQ. MASTER ) THEN WRITE(*,*) " ES A-1 DO_Perm Interleave =" WRITE(*,144) id%KEEP(235), id%KEEP(237), & id%KEEP(242),id%KEEP(243) ENDIF #endif MSG_MAX_BYTES_SOLVE = ( 4 + KEEP(133) ) * KEEP(34) + & KEEP(133) * NBRHS * KEEP(35) & + 16 * KEEP(34) IF (KEEP(237).EQ.0) THEN 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 MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(35) ) ENDIF 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 (LP.GT.0) & 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 ) THEN SMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL SMUMPS_55( SMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = SMUMPS_LBUF_INT IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF SMUMPS_LBUF = (MSG_MAX_BYTES_SOLVE + 2*KEEP(34) )*id%NSLAVES SMUMPS_LBUF = min(SMUMPS_LBUF, 100 000 000) SMUMPS_LBUF = max(SMUMPS_LBUF, & (MSG_MAX_BYTES_SOLVE+2*KEEP(34)) * min(id%NSLAVES,3)) SMUMPS_LBUF = SMUMPS_LBUF + KEEP(34) CALL SMUMPS_53( SMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = SMUMPS_LBUF/KEEP(34) + 1 IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF ENDIF IF ( & ( id%MYID .NE. MASTER ) & .or. & ( 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. & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) & ) THEN ALLOCATE(RHS_MUMPS(id%N*NBRHS),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_MUMPS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N*NBRHS IF (LP > 0) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' GOTO 111 END IF ELSE RHS_MUMPS=>id%RHS ENDIF IF ( I_AM_SLAVE ) THEN LD_RHSCOMP = max(KEEP(89),1) IF (id%MYID.EQ.MASTER) THEN LD_RHSCOMP = max(LD_RHSCOMP, KEEP(247)) ENDIF IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN IF (.NOT.associated(id%RHSCOMP)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF IF (.NOT.associated(id%POSINRHSCOMP)) THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF LENRHSCOMP = size(id%RHSCOMP) LD_RHSCOMP = LENRHSCOMP/id%NRHS ELSE IF (KEEP(221).EQ.1) THEN IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) ENDIF LENRHSCOMP = LD_RHSCOMP*id%NRHS ALLOCATE (id%RHSCOMP(LENRHSCOMP)) NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) ENDIF ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE LENRHSCOMP = LD_RHSCOMP*NBRHS IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) ENDIF ALLOCATE (id%RHSCOMP(LENRHSCOMP)) NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) ENDIF ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF LIWK_SOLVE = 4 * KEEP(28) + 1 IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE( LIWK_SOLVE), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 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) LIW = KEEP(32) 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) IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) ) THEN ALLOCATE(POSINRHSCOMP_N(id%N), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP.GT.0) WRITE(LP,*) & ' ERROR in SMUMPS_301: allocating POSINRHSCOMP_N' INFO(1) = -13 INFO(2) = id%N GOTO 111 END IF NB_BYTES = NB_BYTES + int(size(POSINRHSCOMP_N),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) END IF ELSE LIW=0 END IF 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) & ) & .OR. ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) & ) 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 DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF 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 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif CALL MUMPS_276( 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 CALL MPI_BCAST(UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN 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 (LP > 0) 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 (LP > 0) 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 LIW_PASSED=max(1,LIW) IF (KEEP(89) .GT. 0) THEN CALL SMUMPS_535( 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 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 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 40 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 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 IF ( ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) THEN 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 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 IF ( id%MYID .EQ. MASTER ) THEN 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 CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF ENDIF ENDIF IF ( KEEP(248)==1 ) THEN JEND_RHS = 0 IF (DO_PERMUTE_RHS) THEN 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 STRAT_PERMAM1 = KEEP(242) CALL MUMPS_780 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF 109 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (id%NSLAVES .EQ. 1) THEN IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF 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 IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_772 & (PERM_RHS, id%NRHS, id%N, id%KEEP(28), & id%PROCNODE_STEPS(1), id%STEP(1), id%NSLAVES, & id%Step2node(1), & IERR) ENDIF ENDIF ENDIF ENDIF IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) 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 ( & ( id%MYID .NE. MASTER ) & .or. & ( 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. & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) & ) THEN LD_RHS = id%N IBEG = 1 ELSE IF ( associated(id%RHS) ) THEN LD_RHS = max(id%LRHS, id%N) ELSE LD_RHS = id%N ENDIF IBEG = (BEG_RHS-1) * LD_RHS + 1 ENDIF JBEG_RHS = BEG_RHS IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 ) THEN JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN DO I=1, id%N RHS_MUMPS((PERM_RHS(JBEG_RHS) -1)*LD_RHS+I) & = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 CYCLE 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 DO I=1, id%N RHS_MUMPS((JBEG_RHS -1)*LD_RHS + I) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN IBEG = (JBEG_RHS-1) * LD_RHS + 1 ENDIF ENDIF CALL MPI_BCAST( JBEG_RHS,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0) THEN IBEG_REDRHS= (JBEG_RHS-1)*LD_REDRHS + 1 ELSE IBEG_REDRHS=-142424 ENDIF IF ( I_AM_SLAVE ) THEN IF ( KEEP(221).EQ.0 ) THEN IBEG_RHSCOMP= 1 ELSE IBEG_RHSCOMP= (JBEG_RHS-1)*LD_RHSCOMP + 1 ENDIF ELSE IBEG_RHSCOMP=-152525 ENDIF #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN IF (KEEP(248)==1) THEN NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 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 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)) & STOP_AT_NEXT_EMPTY_COL =.TRUE. IF (COLSIZE.GT.0) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN NBCOL_INBLOC = NBCOL_INBLOC -1 NBRHS_EFF = NBCOL EXIT ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NBCOL.NE.NBRHS_EFF) THEN WRITE(6,*) 'INTERNAL ERROR 1 in SMUMPS_301 ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF 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) JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 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 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 IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN 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 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) 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 & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN 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 & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY & => 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 RHS_SPARSE_COPY = ONE ELSE IF (.NOT. LSCAL) 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)) 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 ENDIF IF (KEEP(23) .NE. 0) THEN IF (MTYPE .NE. 1) THEN IF (KEEP(248)==0) THEN ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in SMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF DO K = 1, NBRHS_EFF KDEC = IBEG+(K-1)*LD_RHS DO I = 1, id%N C_RW2(I)=RHS_MUMPS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) RHS_MUMPS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ELSE IPOS = 1 DO I=1, NBCOL_INBLOC 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 ENDIF ENDIF IF (ERANAL) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+(K-1)*LD_RHS DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = RHS_MUMPS(KDEC+I-1) END DO ENDDO ENDIF ENDIF IF (LSCAL) THEN IF (KEEP(248)==0) THEN IF (MTYPE .EQ. 1) THEN DO K =1, NBRHS_EFF KDEC = (K-1) * LD_RHS + IBEG - 1 DO I = 1, id%N RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * & id%ROWSCA(I) END DO ENDDO ELSE DO K =1, NBRHS_EFF KDEC = (K-1) * LD_RHS + IBEG - 1 DO I = 1, id%N RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * & id%COLSCA(I) END DO ENDDO ENDIF ELSE KDEC=id%IRHS_PTR(JBEG_RHS) IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN RHS_SPARSE_COPY(IPOS) = id%ROWSCA(PERM_RHS(I)) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE DO K = 1, COLSIZE II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) 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 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 END IF ENDIF #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif 30 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF ( I_AM_SLAVE ) THEN IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) .OR. & (KEEP(252).NE.0) ) THEN IF (BUILD_POSINRHSCOMP) THEN IF (KEEP(111).NE.0) THEN WHAT = 2 MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN WHAT = 0 MTYPE_LOC = 1 ELSE WHAT = 1 MTYPE_LOC = MTYPE ENDIF LIW_PASSED=max(1,LIW) IF (WHAT.EQ.0) THEN CALL SMUMPS_639(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(1), IDUMMY, 1, MTYPE_LOC, & WHAT ) ELSE CALL SMUMPS_639(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(1), POSINRHSCOMP_N(1), & id%N, MTYPE_LOC, & WHAT ) ENDIF BUILD_POSINRHSCOMP = .FALSE. ENDIF ENDIF ENDIF 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(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN 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 #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0)) THEN IF (KEEP(248) == 0) THEN IF ( .NOT.I_AM_SLAVE ) THEN CALL SMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) BUILD_POSINRHSCOMP=.FALSE. ELSE LIW_PASSED = max( LIW, 1 ) CALL SMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), & BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) BUILD_POSINRHSCOMP=.FALSE. ENDIF IF (INFO(1).LT.0) GOTO 90 ELSE CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER) 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. 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) 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 45 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_REAL, & 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 IF ( I_AM_SLAVE ) THEN IF (KEEP(237).NE.0) THEN K=1 RHS_MUMPS(1:NBRHS_EFF*LD_RHS) = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IF (POSINRHSCOMP_N(J).NE.0) THEN RHS_MUMPS((K-1) * LD_RHS + J) = & RHS_SPARSE_COPY(IPOS) ENDIF K = K + 1 IPOS = IPOS + COLSIZE ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'INTERNAL ERROR 2 in SMUMPS_301 ', & K, NBRHS_EFF call MUMPS_ABORT() ENDIF ELSE IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0)) THEN 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 DO K = 1, NBCOL_INBLOC KDEC = (K-1) * LD_RHS + IBEG - 1 RHS_MUMPS(KDEC+1:KDEC+id%N) = ZERO DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IF (POSINRHSCOMP_N(I).NE.0) THEN RHS_MUMPS(KDEC+I)= RHS_SPARSE_COPY(IZ) ENDIF ENDDO ENDDO END IF ENDIF ENDIF ELSE IF (I_AM_SLAVE) THEN IF (KEEP(111).NE.0) THEN 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 IEND_GLOB_DEF = id%KEEP(112) id%KEEP(235) = 1 DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN 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+K35_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN 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 50 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 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) RHS_MUMPS( IBEG : & (IBEG + (NBRHS_EFF)*LD_RHS -1) ) = ZERO ENDIF DO K=1, NBRHS_EFF KDEC = (K-1) *LD_RHSCOMP id%RHSCOMP(KDEC+1:KDEC+LD_RHSCOMP)=ZERO END DO IF ((KEEP(235).NE.0).AND. INTERLEAVE_PAR) THEN DO I=IBEG_GLOB_DEF,IEND_GLOB_DEF IF (id%MYID_NODES .EQ. MAP_PIVNUL_LIST(I) ) THEN JJ= POSINRHSCOMP_N(PERM_PIV_LIST(I)) IF (JJ.GT.LD_RHSCOMP) THEN WRITE(6,*) ' Internal ERROR JJ, LD_RHSCOMP=', & JJ, LD_RHSCOMP ENDIF IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN id%RHSCOMP(IBEG_RHSCOMP -1+ & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = & abs(id%DKEEP(2)) ELSE id%RHSCOMP(IBEG_RHSCOMP -1+ & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = ONE ENDIF ENDIF ENDIF ENDDO ELSE DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) JJ= POSINRHSCOMP_N(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP & + JJ) = id%DKEEP(2) ELSE id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP & + JJ) = ONE ENDIF ENDIF ENDDO ENDIF IF ( KEEP(17).NE.0 .and. id%MYID_NODES.EQ.MASTER_ROOT) THEN IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -90999 ENDIF ELSE ENDIF ENDIF IF ( I_AM_SLAVE ) THEN LWCB_SOL_C = LWCB IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN IF ( associated(id%root%RHS_CNTR_MASTER_ROOT) ) THEN PTR_RHS_ROOT => id%root%RHS_CNTR_MASTER_ROOT LPTR_RHS_ROOT = size(id%root%RHS_CNTR_MASTER_ROOT) ELSE LPTR_RHS_ROOT = NBRHS_EFF * SIZE_ROOT IPT_RHS_ROOT = LWCB - LPTR_RHS_ROOT + 1 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1 IPT_RHS_ROOT = LWCB PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT ENDIF ENDIF IF (KEEP(221) .EQ. 2 ) THEN IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE IF ( id%MYID .EQ. MASTER) THEN IF (LD_REDRHS.EQ.SIZE_ROOT) THEN KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_REAL, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 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 II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 ENDIF ENDIF IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF ((id%KEEP(235).EQ.0).and.(id%KEEP(237).EQ.0) ) THEN PRUNED_SIZE_LOADED = 0_8 CALL SMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, & IWCB, LIWCB, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%NA(1),id%LNA,id%NE_STEPS(1), SRW3, MTYPE, & ICNTL(1), 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, id%PROCNODE_STEPS(1), & id%NSLAVES, INFO(1), KEEP(1), KEEP8(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(1), BUILD_POSINRHSCOMP & , 1 , 1 , 1 & , 1 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & ) ELSE IF ((KEEP(235).NE.0).AND.KEEP(221).NE.2.AND. & KEEP(111).EQ.0) THEN DO K=1, NBRHS_EFF DO I=1, LD_RHSCOMP id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO ENDDO ENDDO ELSEIF (KEEP(237).NE.0) THEN DO K=1, NBRHS_EFF DO I=1, LD_RHSCOMP id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO ENDDO ENDDO ENDIF IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF CALL SMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, id%NA(1),id%LNA, & id%NE_STEPS(1), SRW3, MTYPE, ICNTL(1), 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, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1),KEEP(1),KEEP8(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(1), BUILD_POSINRHSCOMP, & NZ_THIS_BLOCK, NBCOL_INBLOC, id%NRHS, & JBEG_RHS , id%Step2node(1), id%KEEP(28), IRHS_SPARSE_COPY(1), & IRHS_PTR_COPY(1), & size(PERM_RHS), PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV & ) ENDIF END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LP.GT.0) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LP.GT.0) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF IF (INFO(1).LT.0) GO TO 90 IF ( KEEP(221) .EQ. 1 ) THEN IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE IF ( id%MYID .EQ. MASTER ) THEN IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 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 II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 ENDIF ENDIF IF ( KEEP(221) .NE. 1 ) THEN IF (ICNTL21 == 0) THEN IF ((.NOT. I_AM_SLAVE).AND.KEEP(237).EQ.0) THEN ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) IF (allocok > 0) THEN ALLOCATE( CWORK(KEEP(247)), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=KEEP(247) ENDIF ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) 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 ( .NOT.I_AM_SLAVE ) THEN IF (KEEP(237).EQ.0) THEN CALL SMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & 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) & ) DEALLOCATE( CWORK ) ELSE CALL SMUMPS_812(id%NSLAVES,id%N, & id%MYID, id%COMM, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) & ,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 & ) ENDIF ELSE IF (KEEP(237).EQ.0) THEN CALL SMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & 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, & id%RHSCOMP(1), LENRHSCOMP, & LSCAL, PT_SCALING(1), size(PT_SCALING) & ) ELSE CALL SMUMPS_812(id%NSLAVES,id%N, & id%MYID, id%COMM, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) & , 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), POSINRHSCOMP_N, & id%N & ) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN 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 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 1 gather sol_driver" CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ELSE 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 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 2 gather sol_driver" CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ENDIF ENDIF ELSE IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) IF ( KEEP(89) .GT. 0 ) THEN CALL SMUMPS_532(id%NSLAVES, & id%N, id%MYID_NODES, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%ISOL_loc(1), & id%SOL_loc(1), 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 ) ENDIF ENDIF ENDIF ENDIF IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN DO I = 1, ICNTL10 write(*,*) 'FIXME: to be implemented' END DO END IF IF (ERANAL) THEN IF ((ICNTL10 .GT. 0) .AND. (ICNTL11 .GT. 0)) THEN IF (id%MYID .EQ. MASTER) THEN GIVSOL = .FALSE. IF (MP .GT. 0) WRITE( MP, 170 ) ALLOCATE(R_RW1(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 776 ENDIF ALLOCATE(C_RW2(id%N),stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 776 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) END IF 776 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL SMUMPS_278( ICNTL(9), id%N, id%NZ, id%A(1), & id%IRN(1), id%JCN(1), & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, & KEEP(1),KEEP8(1) ) ELSE CALL SMUMPS_121( ICNTL(9), id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, & KEEP(1),KEEP8(1) ) ENDIF END IF ELSE CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_REAL, MASTER, & id%COMM, IERR ) ALLOCATE( C_LOCWK54( id%N ), stat =allocok ) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N endif CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL SMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_RW2, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) C_RW2 = SAVERHS - C_RW2 ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF NB_BYTES = NB_BYTES - int(size(C_LOCWK54),8)*K35_8 DEALLOCATE( C_LOCWK54 ) ALLOCATE( R_LOCWK54( id%N ), stat =allocok ) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N endif CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NZ_loc .NE. 0 ) THEN CALL SMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1)) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_RW1, & 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 NB_BYTES = NB_BYTES - int(size(R_LOCWK54),8)*K16_8 DEALLOCATE( R_LOCWK54 ) END IF IF ( id%MYID .EQ. MASTER ) THEN CALL SMUMPS_205(ICNTL(9),INFO(1),id%N,id%NZ, & RHS_MUMPS(IBEG), SAVERHS,R_RW1,C_RW2,GIVSOL, & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MP,ICNTL(1), & KEEP(1),KEEP8(1)) NB_BYTES = NB_BYTES - int(size(R_RW1),8)*K16_8 & - int(size(C_RW2),8)*K35_8 DEALLOCATE(R_RW1) DEALLOCATE(C_RW2) END IF END IF IF ( PROK .AND. ICNTL10 .GT. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .GT. 0 ) WRITE( MPG, 270 ) 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( 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 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 NITREF = ICNTL10 JOBIREF= ICNTL11 IF ( PROKG .AND. ICNTL10 .GT. 0 ) & WRITE( MPG, 240) 'MAXIMUM NUMBER OF STEPS =', NITREF DO I = 1, id%N D( I ) = RONE END DO 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 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 22 CONTINUE IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .eq. 0 ) THEN IF (KEEP(55).NE.0) THEN CALL SMUMPS_119(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE IF ( MTYPE .eq. 1 ) THEN CALL SMUMPS_207 & ( id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) ELSE CALL SMUMPS_207 & ( id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) END IF ENDIF ENDIF END IF ELSE IF ( KASE .eq. 0 ) THEN IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL SMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE CALL SMUMPS_207(id%A_loc(1), & id%NZ_loc, 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 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 END IF END IF IF ( id%MYID .eq. MASTER ) THEN ARRET = CNTL(2) IF (ARRET .LT. 0.0E0) THEN ARRET = sqrt(epsilon(0.0E0)) END IF CALL SMUMPS_206(id%NZ,id%N,SAVERHS,RHS_MUMPS(IBEG), & C_Y, D, R_W, C_W, & IW1, KASE,RINFOG(7), & RINFOG(9), JOBIREF, RINFOG(10), NITREF, NOITER, MP, & KEEP(1),KEEP8(1), ARRET ) END IF IF ( KEEP(54) .ne. 0 ) THEN CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) END IF IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .eq. 14 ) THEN IF (KEEP(55).NE.0) THEN CALL SMUMPS_122( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%NA_ELT, id%A_ELT(1), & SAVERHS, RHS_MUMPS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL SMUMPS_208 & (id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), SAVERHS, & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL SMUMPS_208 & (id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), SAVERHS, & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) END IF ENDIF GOTO 22 END IF END IF ELSE IF ( KASE.eq.14 ) THEN CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_REAL, MASTER, & id%COMM, IERR ) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL SMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(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 IF ( I_AM_SLAVE .and. id%NZ_loc .NE. 0 ) THEN CALL SMUMPS_193( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(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) END IF GOTO 22 END IF END IF IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .GT. 0 ) THEN IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF END IF END IF CALL MPI_BCAST( KASE , 1, MPI_INTEGER, MASTER, & id%COMM, IERR) CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) IF ( KASE .GT. 0 ) THEN BUILD_POSINRHSCOMP=.FALSE. IF ( .NOT.I_AM_SLAVE ) THEN CALL SMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, C_Y(1), id%N, 1, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) ELSE LIW_PASSED = max( LIW, 1 ) CALL SMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, C_Y(1), id%N, 1, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), & BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) CALL SMUMPS_245( id%root, id%N, id%S(1), LA_PASSED, & id%IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, C_Y, & id%N, NBRHS_EFF, id%NA(1), id%LNA, id%NE_STEPS(1), SRW3, SOLVET, & ICNTL(1), 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, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(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(1), BUILD_POSINRHSCOMP & , 1 , 1 , 1 & , 1 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & ) END IF IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 IF ( .NOT. I_AM_SLAVE .AND. INFO(1) .GE. 0) THEN ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) IF (allocok > 0) THEN ALLOCATE( CWORK(KEEP(247)), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=KEEP(247) ENDIF ENDIF ENDIF 89 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GO TO 90 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 ) IF ( .NOT. I_AM_SLAVE ) THEN CALL SMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & SOLVET, C_Y, id%N, NBRHS_EFF, & 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, size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING)) DEALLOCATE( CWORK ) ELSE CALL SMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & SOLVET, C_Y, id%N, NBRHS_EFF, & 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, & id%RHSCOMP(1), LENRHSCOMP, & LSCAL, PT_SCALING(1), size(PT_SCALING)) ENDIF GO TO 22 ELSEIF ( KASE .LT. 0 ) THEN INFO( 1 ) = INFO( 1 ) + 8 END IF IF ( id%MYID .eq. MASTER ) THEN NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(D ),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W,D) DEALLOCATE(IW1) ENDIF IF ( PROKG ) THEN IF (NITREF.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, 141 ) 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS &=', NOITER ENDIF ENDIF IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF END IF IF ( PROK .AND. ICNTL10 .GT.0 ) WRITE( MP, 131 ) IF (ICNTL11 .GT. 0) THEN IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL SMUMPS_278( MTYPE, id%N, id%NZ, id%A(1), & id%IRN(1), id%JCN(1), & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) ELSE CALL SMUMPS_121( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) ENDIF END IF ELSE CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_REAL, MASTER, & id%COMM, IERR ) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL SMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_W, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) C_W = SAVERHS - C_W ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL SMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_Y, & 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 END IF IF (id%MYID .EQ. MASTER) THEN IF ((MPG .GT. 0) .AND. (NITREF .GT. 0)) WRITE( MPG, 65 ) IF ((MPG .GT. 0) .AND. (NITREF .LE. 0)) WRITE( MPG, 170 ) GIVSOL = .FALSE. CALL SMUMPS_205(MTYPE,INFO(1),id%N,id%NZ,RHS_MUMPS(IBEG), & SAVERHS,R_Y,C_W,GIVSOL, & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) &'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', RINFOG(7) WRITE( MPG, 115 ) &'------(8):---------------------------- (W2)=', RINFOG(8) 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 IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) 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) END IF IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0 .AND. KEEP(237).EQ.0 ) THEN IF ((KEEP(221).NE.1 .AND. ICNTL(9) .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN ALLOCATE( C_RW1( id%N ),stat =allocok ) 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 KDEC = (K-1)*LD_RHS+IBEG-1 DO 70 I = 1, id%N C_RW1(I) = RHS_MUMPS(KDEC+I) 70 CONTINUE DO 80 I = 1, id%N JPERM = id%UNS_PERM(I) RHS_MUMPS( KDEC+JPERM ) = C_RW1( I ) 80 CONTINUE END DO DEALLOCATE( C_RW1 ) END IF END IF IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1 & .and. KEEP(237).EQ.0 ) THEN 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) & (RHS_MUMPS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN BEG_RHS = BEG_RHS + NBRHS_EFF ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF ENDDO IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) & .AND. ( KEEP(237).EQ.0 ) & .AND. ( ICNTL21.EQ.0 ) & .AND. ( KEEP(221) .NE.1 ) & .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 RHS_MUMPS((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 RHS_MUMPS((JBEG_NEW -1)*LD_RHS + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF 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 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 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 JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,LD_RHSCOMP id%RHSCOMP((JBEG_NEW -1)*LD_RHSCOMP + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF id%INFO(26) = int(NB_BYTES_MAX / 1000000_8, 4) CALL MUMPS_243( 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 90 CONTINUE IF (INFO(1) .LT.0 ) THEN ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL SMUMPS_582(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF 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 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(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF CALL SMUMPS_57( IERR ) CALL SMUMPS_59( IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF IF ( & ( & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & .and. ICNTL21.ne.0 ) & .or. & ( KEEP(237).NE.0 ) & ) & THEN IF ( I_AM_SLAVE ) THEN IF (associated(RHS_MUMPS) ) THEN NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 DEALLOCATE(RHS_MUMPS) ENDIF ENDIF ENDIF NULLIFY(RHS_MUMPS) ELSE IF (associated(RHS_MUMPS)) THEN NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) END IF END IF IF (I_AM_SLAVE) THEN IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K35_8 DEALLOCATE(SRW3) ENDIF IF (allocated(POSINRHSCOMP_N)) THEN NB_BYTES = NB_BYTES - int(size(POSINRHSCOMP_N),8)*K34_8 DEALLOCATE(POSINRHSCOMP_N) ENDIF IF (LSCAL .AND. ICNTL21==1) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (associated(id%S).AND.KEEP(201).GT.0) THEN 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 IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) ENDIF IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) NULLIFY(id%POSINRHSCOMP) ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K35_8 DEALLOCATE( WORK_WCB ) ENDIF NULLIFY( WORK_WCB ) ENDIF RETURN 65 FORMAT (//' ERROR ANALYSIS AFTER ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' VECTOR SOLUTION FOR COLUMN ',I12) 115 FORMAT(1X, A44,1P,D9.2) 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, A42,I4) END SUBROUTINE SMUMPS_301 SUBROUTINE SMUMPS_245(root, N, A, LA, IW, LIW, W, LWC, & IWCB,LIWW,RHS,LRHS,NRHS,NA,LNA,NE_STEPS, W2, & MTYPE, ICNTL, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1,LIW1, & PROCNODE_STEPS, SLAVEF, & INFO, KEEP,KEEP8, 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, BUILD_POSINRHSCOMP & , 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 & ) 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 LWC,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 LRHS, NRHS, LRHSCOMP REAL A(LA), W(LWC), RHS(LRHS,NRHS), & W2(KEEP(133)), & RHSCOMP(LRHSCOMP,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP(KEEP(28)) 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 LPTR_RHS_ROOT REAL PTR_RHS_ROOT(LPTR_RHS_ROOT) LOGICAL BUILD_POSINRHSCOMP INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,LPANEL_POS INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB,PTRACB INTEGER MTYPE_LOC 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' EXTERNAL SMUMPS_248, SMUMPS_249 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) 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 INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_808 EXTERNAL :: MUMPS_808 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 NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) PTRACB = PTRICB + KEEP(28) IPOOL = PTRACB + 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 in SMUMPS_245", & 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 ( 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_276(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_276(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_276(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 #if defined(NOT_USED) IF ( KEEP(201).GT.0) THEN CALL SMUMPS_789(KEEP(28), & KEEP(38), KEEP(20) ) ENDIF #endif nb_nodes_RHS = 0 #if defined(check) WRITE(*,*) "NBCOL_INBLOC=",NBCOL_INBLOC WRITE(*,*) "JBEG SIZE=",JBEG_RHS, SIZE(IRHS_PTR) #endif 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_276(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_797( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_797( & .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_809(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_808 & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_802( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) 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_583(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_248(N, A(1), LA, IW(1), LIW, W(1), & LWC, RHS, LRHS, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, & NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP,KEEP8, & 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 & ) 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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(I.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_248(N, A(1), LA, IW(1), LIW, W(1), & LWC, RHS, LRHS, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, & Pruned_SONS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP,KEEP8, & 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 & ) DEALLOCATE(prun_NA) ENDIF BUILD_POSINRHSCOMP = .FALSE. #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM SMUMPS_248,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) 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)) 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 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_798( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_798( & .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_809(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_808 & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_803( & 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_584(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_276(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 ( ( 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 write(6,*) " CPA to be double checked " 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_643( & 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_643', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL SMUMPS_286( 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)) IF(KEEP(201).GT.0)THEN CALL SMUMPS_598(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after SMUMPS_598 ', & 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 defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(111).NE.0) & I_WORKED_ON_ROOT = .FALSE. 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_797( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_797( & .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_809(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_808 & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_802( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL SMUMPS_584(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.SPECIAL_ROOT_REACHED ) THEN PTR_RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO 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_249( N, A, LA, IW, LIW, W(1), LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, & W2, NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, & 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) 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_249( N, A, LA, IW, LIW, W(1), LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, & W2, NE_STEPS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, & 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) ENDIF #if defined(V_T) CALL VTEND(back_soln,ierr) #endif ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N WRITE (MP,99992) IF (N.GT.0) WRITE (MP,99993) (RHS(I,1),I=1,K) IF (N.GT.0.and.NRHS>1) & WRITE (MP,99994) (RHS(I,2),I=1,K) 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_245 SUBROUTINE SMUMPS_521(NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NRHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, & LSCAL, SCALING, LSCALING) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, LCWORK REAL RHS (LRHS, NRHS) 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) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER STATUS(MPI_STATUS_SIZE), IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER SK38, SK20 INTEGER, PARAMETER :: FIN = -1 INTEGER, PARAMETER :: yes = 1 INTEGER, PARAMETER :: no = 0 INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist(:) INTEGER :: ONE_PACK INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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 DO J=1, NRHS DO I=1,N RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDDO ENDIF RETURN ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.0) THEN DO J=1, NRHS IF ( I_AM_SLAVE ) THEN CALL MPI_SEND(RHS(1, J), N, MPI_REAL, MASTER, & GatherSol, COMM, IERR) & ELSE CALL MPI_RECV(RHS(1, J), N, MPI_REAL, & 1, & GatherSol, COMM, STATUS, IERR ) IF (LSCAL) THEN DO I=1,N RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDIF ENDIF ENDDO RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .GE. MAXSurf) THEN ONE_PACK = yes ELSE IF (LCWORK .GE. MAXNPIV_estim) THEN ONE_PACK = no ELSE WRITE(*,*) & "Internal error 2 in SMUMPS_521:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (ONE_PACK .EQ. no .AND. I_AM_SLAVE) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_521:", & TYPE_PARAL, LCWORK, KEEP(246),KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (TYPE_PARAL .EQ. 0) &CALL MPI_BCAST(ONE_PACK, 1, MPI_INTEGER, & MASTER, COMM, IERR) 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_521 ' 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_275(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.AND.LSCAL) & CALL SMUMPS_522 ( ONE_PACK, .TRUE. ) ELSE IF (NPIV.GT.0) & CALL SMUMPS_522 ( ONE_PACK, .FALSE.) ENDIF ENDIF ENDDO CALL SMUMPS_523() 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 (ONE_PACK.EQ.yes) THEN CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV*NRHS, MPI_REAL, & COMM, IERR) IF (LSCAL) THEN DO J=1, NRHS DO I=1,NPIV RHS(IROWlist(I),J)= & CWORK(I+(J-1)*NPIV)*SCALING(IROWlist(I)) ENDDO END DO ELSE DO J=1, NRHS DO I=1,NPIV RHS(IROWlist(I),J)= CWORK(I+(J-1)*NPIV) ENDDO END DO ENDIF ELSE DO J=1,NRHS 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),J)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE DO I=1,NPIV RHS(IROWlist(I),J)=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_522 ( ONE_PACK, SCALE_ONLY ) INTEGER, intent(in) :: ONE_PACK LOGICAL, intent(in) :: SCALE_ONLY INTEGER III IF (SCALE_ONLY) THEN DO II=1,NPIV I=IW(J1+II-1) DO J=1, NRHS RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDDO RETURN ENDIF DO II=1,NPIV I=IW(J1+II-1) DO J=1, NRHS CWORK(II+(J-1)*NPIV) = RHS(I,J) ENDDO ENDDO 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 ) IF (ONE_PACK.EQ.yes) THEN CALL MPI_PACK(CWORK(1), NPIV*NRHS, MPI_REAL, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ELSE III = 1 DO J=1,NRHS CALL MPI_PACK(CWORK(III), NPIV, MPI_REAL, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) III =III+NPIV ENDDO ENDIF N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL SMUMPS_523() END IF RETURN END SUBROUTINE SMUMPS_522 SUBROUTINE SMUMPS_523() 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_523 END SUBROUTINE SMUMPS_521 SUBROUTINE SMUMPS_812(NSLAVES, N, MYID, COMM, & RHS, LRHS, NRHS, 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_N, LPOS_N ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHS, LPOS_N REAL RHS (LRHS, NRHS) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSCOMP_N(LPOS_N) 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 INTEGER STATUS(MPI_STATUS_SIZE), 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) IF (POSINRHSCOMP_N(I).NE.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHS(I,K)*SCALING(I) ELSE RHS_SPARSE_COPY(IZ)=RHS(I,K) ENDIF ENDIF ENDDO K = K + 1 ENDDO RETURN ENDIF IF (I_AM_SLAVE) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IF (POSINRHSCOMP_N(I).NE.0) THEN RHS_SPARSE_COPY(IZ)=RHS(I,K) ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_REAL, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in SMUMPS_812 ' 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) IF (POSINRHSCOMP_N(II).NE.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 IF (LSCAL) & CALL SMUMPS_813 ( .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_813 ( .FALSE. ) ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL SMUMPS_814() 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_813 ( 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_814() END IF RETURN END SUBROUTINE SMUMPS_813 SUBROUTINE SMUMPS_814() 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_814 END SUBROUTINE SMUMPS_812 SUBROUTINE SMUMPS_535(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_275 EXTERNAL MUMPS_275 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_275( 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_535 SUBROUTINE SMUMPS_532( & SLAVEF, N, MYID_NODES, & MTYPE, RHS, LD_RHS, NRHS, & ISOL_LOC, SOL_LOC, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & scaling_data, LSCAL, NB_RHSSKIPPED) 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, NRHS, LD_RHS INTEGER LSOL_LOC, BEG_RHS, NB_RHSSKIPPED INTEGER ISOL_LOC(LSOL_LOC) REAL SOL_LOC( LSOL_LOC, BEG_RHS+NRHS+NB_RHSSKIPPED-1) REAL RHS( LD_RHS , NRHS) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER JJ, J1, ISTEP, K, JEMPTY, JEND INTEGER IPOS, LIELL, NPIV LOGICAL ROOT REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NRHS-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(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 DO JJ=J1,J1+NPIV-1 K=K+1 IF (NB_RHSSKIPPED.GT.0) & SOL_LOC(K, BEG_RHS:JEMPTY) = ZERO IF (LSCAL) THEN SOL_LOC(K,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(K)*RHS(IW(JJ),1:NRHS) ELSE SOL_LOC(K,JEMPTY+1:JEND) = & RHS(IW(JJ),1:NRHS) ENDIF ENDDO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_532 SUBROUTINE SMUMPS_638 & (NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NRHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP, LENPOSINRHSCOMP, & BUILD_POSINRHSCOMP, ICNTL, INFO) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, LENPOSINRHSCOMP INTEGER ICNTL(40), INFO(40) REAL RHS (LRHS, NRHS) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N), POSINRHSCOMP(LENPOSINRHSCOMP) LOGICAL BUILD_POSINRHSCOMP INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX REAL, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER I, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER STATUS(MPI_STATUS_SIZE), IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER SK38, SK20, IPOSINRHSCOMP INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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) ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_276(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) 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 ) RHS( BUF_INDX(I), K ) = ZERO 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 IF (I_AM_SLAVE) THEN IF (BUILD_POSINRHSCOMP) THEN IPOSINRHSCOMP = 1 POSINRHSCOMP = -9678 ENDIF IF (MYID.NE.MASTER) RHS = ZERO DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(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 (BUILD_POSINRHSCOMP) THEN POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF IF (MYID.NE.MASTER) THEN 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_640() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL SMUMPS_640() ENDIF DEALLOCATE (BUF_INDX, BUF_RHS) RETURN CONTAINS SUBROUTINE SMUMPS_640() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_REAL, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX(I) DO K = 1, NRHS RHS( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO BUF_EFFSIZE = 0 RETURN END SUBROUTINE SMUMPS_640 END SUBROUTINE SMUMPS_638 SUBROUTINE SMUMPS_639 & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP, POSINRHSCOMP_N, LPIRC_N, MTYPE, & WHAT ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID_NODES, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N), POSINRHSCOMP(KEEP(28)) INTEGER LPIRC_N, WHAT, MTYPE INTEGER POSINRHSCOMP_N(LPIRC_N) INTEGER ISTEP INTEGER NPIV INTEGER SK38, SK20, IPOS, LIELL INTEGER JJ, J1 INTEGER IPOSINRHSCOMP INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 IF (WHAT .NE. 0.AND. WHAT.NE.1.AND.WHAT.NE.2) THEN WRITE(*,*) "Internal error in SMUMPS_639" CALL MUMPS_ABORT() ENDIF 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 IPOSINRHSCOMP = 1 POSINRHSCOMP = -9678 IF (WHAT .NE. 0) THEN POSINRHSCOMP_N = 0 ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP IF (WHAT .NE. 0) 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)) ENDIF IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_N(IW(JJ)) = IPOSINRHSCOMP+JJ-J1 END DO ENDIF IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_639 SUBROUTINE SMUMPS_248(N, A, LA, IW, LIW, WCB, LWCB, & RHS, LRHS, NRHS, & PTRICB, IWCB, LIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, BUILD_POSINRHSCOMP, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, & NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, INFO, & KEEP,KEEP8, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE SMUMPS_OOC IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER N, LIW, LWCB, LPOOL, LIWCB, LNA INTEGER SLAVEF, MYLEAF, COMM, MYID INTEGER INFO( 40 ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER LRHS, NRHS REAL A( LA ), RHS( LRHS, NRHS ), WCB( LWCB ) INTEGER 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) ) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSCOMP(KEEP(28)), LRHSCOMP LOGICAL BUILD_POSINRHSCOMP REAL RHSCOMP( LRHSCOMP, NRHS ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGSOU, DUMMY(1) LOGICAL FLAG INTEGER NBFIN, MYROOT INTEGER POSIWCB,POSWCB,PLEFTWCB INTEGER INODE INTEGER RHSCOMPFREEPOS INTEGER I INTEGER III, NBROOT,LEAF LOGICAL BLOQ EXTERNAL MUMPS_275 INTEGER MUMPS_275 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1 IF (BUILD_POSINRHSCOMP) RHSCOMPFREEPOS= 1 DO I = 1, KEEP(28) NSTK_S(I) = NE_STEPS(I) ENDDO PTRICB = 0 CALL MUMPS_362(N, LEAF, NBROOT, MYROOT, MYID, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) NBFIN = SLAVEF IF ( MYROOT .EQ. 0 ) THEN NBFIN = NBFIN - 1 DUMMY(1) = 1 CALL SMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF) END IF MYLEAF = LEAF - 1 III = 1 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL SMUMPS_574 & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF BLOQ = ( ( III .EQ. LEAF ) & ) CALL SMUMPS_303( 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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL SMUMPS_574 & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE CALL SMUMPS_302( 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, RHS, LRHS, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & MYROOT, INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL SMUMPS_150( MYID,COMM,BUFR, & LBUFR,LBUFR_BYTES ) RETURN END SUBROUTINE SMUMPS_248 RECURSIVE SUBROUTINE SMUMPS_323 & ( 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, STEP, PROCNODE_STEPS, & RHS, LRHS & ) USE SMUMPS_OOC USE SMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8) :: LA INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) 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 ) INTEGER LRHS REAL RHS(LRHS, NRHS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, K, JJ INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PTRX, PTRY, PDEST, I INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG EXTERNAL MUMPS_275 INTEGER MUMPS_275 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, & LONG, 1, MPI_INTEGER, COMM, IERR ) 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 .LT. LONG * NRHS) THEN INFO( 1 ) = -11 INFO( 2 ) = PLEFTWCB - POSWCB - 1 + LONG * NRHS 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 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_REAL, COMM, IERR ) DO I = 1, LONG RHS(IWCB(I),K) = RHS(IWCB(I),K) +WCB(PLEFTWCB+I-1) 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 ) PTRY = PLEFTWCB PTRX = PLEFTWCB + NCV * NRHS PLEFTWCB = PLEFTWCB + (NPIV + NCV) * NRHS IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 INFO(2) = -POSWCB + PLEFTWCB -1 GO TO 260 END IF DO K=1, NRHS 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 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_643( & 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 ( NRHS == 1 ) THEN CALL sgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE CALL sgemm( 'N', 'N', NCV, NRHS, NPIV, ALPHA, & A(APOS), NCV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) ENDIF ELSE IF ( NRHS == 1 ) THEN CALL sgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE CALL sgemm( 'T', 'N', NCV, NRHS, NPIV, ALPHA, & A(APOS), NPIV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) ENDIF ENDIF IF (KEEP(201).GT.0) THEN CALL SMUMPS_598(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 PDEST = MUMPS_275( 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 DO I = 1, NCV JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) DO K=1, NRHS RHS(JJ,K)= RHS(JJ,K) + WCB(PTRY+I-1+(K-1)*NCV) ENDDO END DO 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_78( NRHS, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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 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_44( MYID, SLAVEF, COMM ) 270 CONTINUE RETURN END SUBROUTINE SMUMPS_323 SUBROUTINE SMUMPS_302( 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, & RHS, LRHS, NRHS, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & MYROOT, & INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & & ) USE SMUMPS_OOC USE SMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MTYPE INTEGER INODE, LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIWCB, LWCB, LIW, POSWCB, PLEFTWCB, POSIWCB INTEGER(8) :: LA INTEGER N, LPOOL, III, LEAF, NBFIN INTEGER MYROOT INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER LRHS, NRHS REAL WCB( LWCB ), A( LA ) REAL RHS(LRHS, NRHS ), 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(KEEP(28)), LRHSCOMP, RHSCOMPFREEPOS REAL RHSCOMP(LRHSCOMP, NRHS) LOGICAL BUILD_POSINRHSCOMP EXTERNAL sgemv, strsv, sgemm, strsm, MUMPS_275 INTEGER MUMPS_275 REAL ALPHA,ONE,ZERO PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, & IERR, IFR_ini, & IFR, LIELL, JJ, & NELIM, PLEFT, PCB_COURANT, PPIV_COURANT INTEGER IPOSINRHSCOMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG, OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER POSWCB1,POSWCB2 INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, & JFIN, NBJ, NUPDATE_PANEL, & PPIV_PANEL, PCB_PANEL, NBK, TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB INTEGER LDAJ, 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 ) 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_643( & 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_755( & 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 IFR = 0 DO JJ = J1, J3 J = IW( JJ ) IFR = IFR + 1 DO K=1,NRHS RHS_ROOT(IFR+NPIV*(K-1)) = RHS(J,K) END DO END DO 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 DUMMY (1) = 1 CALL SMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF) 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_690( LDAJ_FIRST_PANEL ) ENDIF PLEFT = PLEFTWCB PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + LIELL * NRHS IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 INFO(2) = PLEFTWCB - POSWCB - 1 GO TO 260 END IF IF (KEEP(201).EQ.1) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV DO K=1, NRHS IFR = PPIV_COURANT + (K-1)*LIELL - 1 DO JJ = J1, J3 J = IW(JJ) IFR = IFR + 1 WCB(IFR) = RHS(J,K) ENDDO IF (NCB.GT.0) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR = IFR + 1 WCB(IFR) = RHS(J,K) RHS (J,K) = ZERO ENDDO ENDIF END DO ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV*NRHS IFR = PPIV_COURANT - 1 OMP_FLAG = NRHS.GT.4 IFR_ini = IFR DO 130 JJ = J1, J3 J = IW(JJ) IFR = IFR_ini + (JJ-J1) + 1 DO K=1, NRHS WCB(IFR+(K-1)*NPIV) = RHS(J,K) END DO 130 CONTINUE IFR = PCB_COURANT - 1 IF (NPIV .LT. LIELL) THEN IFR_ini = IFR DO 140 JJ = J3 + 1, J2 J = IW(JJ) IFR = IFR_ini + (JJ-J3) DO K=1, NRHS WCB(IFR+(K-1)*NCB) = RHS(J,K) RHS(J,K)=ZERO ENDDO 140 CONTINUE 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_667(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_698( & 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+J-1 PCB_PANEL = PPIV_PANEL+NBJ APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN IF ( NRHS == 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 CALL strsm( 'L','L','N','U', NBJ, NRHS, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF ENDIF ELSE IF (NRHS == 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 CALL strsm('L','L','N','N',NBJ, NRHS, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) 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 ( NRHS == 1 ) THEN CALL strsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, & WCB(PPIV_COURANT), 1 ) ELSE CALL strsm( 'L','U','T','U', NPIV, NRHS, ONE, & A(APOS), NPIV, WCB(PPIV_COURANT), & NPIV ) ENDIF ELSE IF ( MTYPE .eq. 1 ) THEN IF ( NRHS == 1) THEN CALL strsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE CALL strsm( 'L','U','T','U', NPIV, NRHS, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV ) ENDIF ELSE IF (NRHS == 1) THEN CALL strsv( 'L', 'N', 'N', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE CALL strsm('L','L','N','N',NPIV, NRHS, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV) 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 ( NRHS == 1 ) THEN CALL sgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), & NPIV, WCB(PPIV_COURANT), 1, ONE, & WCB(PCB_COURANT), 1) ELSE CALL sgemm('T', 'N', NUPDATE, NRHS, NPIV, ALPHA, & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) END IF ELSE IF ( NRHS == 1 ) THEN CALL sgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), & LIELL, WCB(PPIV_COURANT), 1, & ONE, WCB(PCB_COURANT), 1 ) ELSE CALL sgemm('N', 'N', NUPDATE, NRHS, NPIV, ALPHA, & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) END IF END IF END IF END IF IF (BUILD_POSINRHSCOMP) THEN POSINRHSCOMP(STEP(INODE)) = RHSCOMPFREEPOS RHSCOMPFREEPOS = RHSCOMPFREEPOS + NPIV ENDIF IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) IF ( KEEP(50) .eq. 0 ) THEN DO K=1,NRHS IFR = PPIV_COURANT + (K-1)*LD_WCBPIV RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = & WCB(IFR:IFR+NPIV-1) ENDDO ELSE IFR = PPIV_COURANT - 1 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 DO IF(JJ .GT. J3) EXIT IFR = IFR + 1 IF(IW(JJ+LIELL) .GT. 0) THEN DO K=1, NRHS RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR+(K-1)*LD_WCBPIV ) * A( APOS1 ) 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 DO K=1, NRHS POSWCB1 = IFR+(K-1)*LD_WCBPIV POSWCB2 = POSWCB1+1 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = WCB(POSWCB1)*A(APOS1) & + WCB(POSWCB2)*A(APOSOFF) RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A(APOSOFF) & + WCB(POSWCB2)*A(APOS2) 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 IFR = IFR+1 ENDIF ENDDO END IF IF (KEEP(201).GT.0) THEN CALL SMUMPS_598(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 IF ( MYROOT .EQ. 0 ) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN DUMMY (1) = 1 CALL SMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF) ENDIF END IF GO TO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN IF (MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 DO 190 I = 1, NUPDATE DO K=1, NRHS RHS( IW(J3 + I), K ) = RHS( IW(J3 + I), K ) & + WCB(PCB_COURANT + I-1 +(K-1)*LD_WCBCB) ENDDO 190 CONTINUE 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_78( NRHS, INODE, FPERE, NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), & MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), SLAVEF), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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_49( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CALL SMUMPS_72( NRHS, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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*KEEP(35) + & ( Effective_CB_Size + 4 ) * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS*KEEP(35) + & ( Effective_CB_Size + 4 ) * KEEP( 34 ) GOTO 260 END IF END DO END IF PLEFTWCB = PLEFTWCB - LIELL*NRHS 270 CONTINUE RETURN 260 CONTINUE CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE SMUMPS_302 RECURSIVE SUBROUTINE SMUMPS_303( 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, STEP, PROCNODE_STEPS, & RHS, LRHS & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB INTEGER LIW INTEGER(8) :: LA INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) 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)) INTEGER LRHS REAL RHS(LRHS, NRHS) LOGICAL FLAG INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) INTEGER MSGSOU, MSGTAG, MSGLEN 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 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_44( MYID, SLAVEF, COMM ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL SMUMPS_323( 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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) END IF END IF RETURN END SUBROUTINE SMUMPS_303 SUBROUTINE SMUMPS_249(N, A, LA, IW, LIW, W, LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , TO_PROCESS, SIZE_TO_PROCESS & ) USE SMUMPS_OOC USE SMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER N,LIW,LIWW,LWC,LPOOL,LNA INTEGER SLAVEF,MYLEAF,COMM,MYID INTEGER LPANEL_POS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NA(LNA),NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER PANEL_POS(LPANEL_POS) INTEGER INFO(40) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)),PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LRHS, NRHS REAL A(LA), RHS(LRHS,NRHS), 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(KEEP(28)) REAL RHSCOMP(LRHSCOMP,NRHS) INTEGER LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) INTEGER MUMPS_275 EXTERNAL MUMPS_275 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INTEGER POSIWCB,POSWCB,K INTEGER(8) :: APOS, IST INTEGER NPIV INTEGER IPOS,LIELL,NELIM,IFR,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 REAL ALPHA,ONE,ZERO PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) LOGICAL BLOQ,DEBUT INTEGER PROCDEST, DEST INTEGER POSINDICES, IPOSINRHSCOMP INTEGER DUMMY(1) INTEGER 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 LOGICAL DEJA_SEND( 0:SLAVEF-1 ) INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & PTWCB_PANEL, NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL LOGICAL MUMPS_170 INTEGER MUMPS_330 EXTERNAL sgemv, strsv, strsm, sgemm, & MUMPS_330, & MUMPS_170 PLEFTW = 1 POSIWCB = LIWW POSWCB = LWC NROOT = 0 NBLEAF = NA(1) NBROOT = NA(2) DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_275(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_275(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_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, & SLAVEF) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) THEN GOTO 340 ENDIF ENDIF 50 CONTINUE BLOQ = ( ( III .EQ. IIPOOL ) & ) CALL SMUMPS_41( 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) 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 60 CONTINUE 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 DO JJ = J1, J2 J = IW( JJ ) IFR = IFR + 1 DO K=1,NRHS RHS(J,K) = RHS_ROOT(IFR+NPIV*(K-1)) END DO END DO 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)), & SLAVEF) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CALL SMUMPS_78( NRHS, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1 ), PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = LONG * KEEP(35) + & ( LONG + 2 ) * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = LONG * KEEP(35) + & ( LONG + 2 ) * 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_170( & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) TYPENODE = MUMPS_330(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 - NCB*NRHS .LT. PLEFTW - 1 ) THEN CALL SMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - NCB*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = NCB * NRHS - POSWCB - PLEFTW + 1 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 - NCB*NRHS PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = NCB 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 DO JJ = J1, J2 - KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*NCB) = RHS(J,K) ENDDO ENDDO IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1 DO K=1, NRHS IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+(K-1)*NCB) = ALPHA ELSE W(IFR+(K-1)*NCB) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL SMUMPS_63(NRHS, INODE, & W(Offset+PTRACB(STEP(INODE))), EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL SMUMPS_151(NRHS,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) IPOS = IPOS + 1 IF (KEEP(201).GT.0) THEN CALL SMUMPS_643( & 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_690( LIELL ) IF (KEEP(50).NE.1) THEN CALL SMUMPS_755( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL END IF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. LIELL*NRHS ) THEN CALL SMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. LIELL*NRHS ) THEN INFO(1) = -11 INFO(2) = LIELL*NRHS - POSWCB GOTO 330 END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN CALL SMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 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 - LIELL*NRHS PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = LIELL 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 (KEEP(252).EQ.0) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) DO K=1, NRHS IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-1)*LIELL) = ZERO ENDDO ELSE DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-1)*LIELL) = RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO ENDIF END DO IFR = PTWCB + NPIV - 1 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 DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*LIELL) = RHS(J,K) ENDDO ENDDO IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1 DO K=1, NRHS IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+(K-1)*LIELL) = ALPHA ELSE W(IFR+(K-1)*LIELL) = 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_641(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 + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN CALL SMUMPS_667(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_698( & 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 ( NRHS == 1 ) THEN IF (NCB_PANEL.NE.0) THEN CALL sgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( NBJ + PTWCB_PANEL ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ENDIF IF (MTYPE.NE.1) THEN CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL strsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ENDIF ELSE IF (NCB_PANEL.NE.0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(NBJ+PTWCB_PANEL),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ENDIF IF (MTYPE.NE.1) THEN CALL strsm('L','L','T','U',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE CALL strsm('L','L','T','N',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) 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 (NRHS == 1) THEN CALL sgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(NPIV + PTWCB), 1, & ONE, & W(PTWCB), 1 ) ELSE CALL sgemm('T','N', NPIV, NRHS, NCB, ALPHA, A(IST), LIELL, & W(NPIV+PTWCB), LIELL, ONE, & W(PTWCB), LIELL) 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 ( NRHS == 1 ) THEN CALL sgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( NPIV + PTWCB ), & 1, ONE, & W(PTWCB), 1 ) ELSE CALL sgemm( 'N', 'N', NPIV, NRHS, NCB, ALPHA, & A(IST), NPIV, W(NPIV+PTWCB),LIELL, & ONE, W(PTWCB),LIELL) END IF END IF ENDIF IF ( MTYPE .eq. 1 ) THEN IF ( NRHS == 1 ) THEN CALL strsv('L', 'T', 'N', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL strsm('L','L','T','N', NPIV, NRHS, ONE, A(APOS), & LIELL, W(PTWCB), LIELL) ENDIF ELSE IF ( KEEP(50) .EQ. 0 ) THEN IF ( NRHS == 1 ) THEN CALL strsv('U','N','U', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL strsm('L','U','N','U', NPIV, NRHS, ONE, A(APOS), & LIELL,W(PTWCB),LIELL) END IF ELSE IF ( NRHS == 1 ) THEN CALL strsv('U','N','U', NPIV, A(APOS), NPIV, & W(PTWCB), 1) ELSE CALL strsm('L','U','N','U',NPIV, NRHS, ONE, A(APOS), & NPIV, W(PTWCB), LIELL) END IF END IF END IF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF DO 150 I = 1, NPIV JJ = IW(J1 + I - 1) DO K=1, NRHS RHS(JJ, K) = W(PTWCB+I-1+(K-1)*LIELL) ENDDO 150 CONTINUE 160 CONTINUE IF (KEEP(201).GT.0) THEN CALL SMUMPS_598(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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_275(PROCNODE_STEPS(STEP(IF)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL SMUMPS_78( NRHS, IF, 0, 0, LIELL, & LIELL - KEEP(253), & IW( POSINDICES ), & W ( PTRACB(STEP( INODE ))), PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NPIV * KEEP(35) + 2 * 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_151(NRHS,N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF GOTO 50 330 CONTINUE CALL SMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, & SLAVEF) 340 CONTINUE CALL SMUMPS_150( MYID,COMM,BUFR, & LBUFR,LBUFR_BYTES ) RETURN END SUBROUTINE SMUMPS_249 RECURSIVE SUBROUTINE SMUMPS_41( & 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, RHS, & LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER LWC REAL W( LWC ) INTEGER POSIWCB, POSWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(40) INTEGER PLEFTW, KEEP( 500) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) REAL A( LA ), W2( KEEP(133) ) INTEGER LRHS, NRHS REAL RHS(LRHS, NRHS) INTEGER MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) REAL RHSCOMP(LRHSCOMP,NRHS) INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER STATUS( MPI_STATUS_SIZE ), IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN 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_44( MYID, SLAVEF, COMM ) ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL SMUMPS_42( 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) END IF END IF RETURN END SUBROUTINE SMUMPS_41 RECURSIVE SUBROUTINE SMUMPS_42( & 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) USE SMUMPS_OOC USE SMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER LWC REAL W( LWC ) INTEGER POSIWCB, POSWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(40) INTEGER PLEFTW, KEEP( 500) INTEGER(8) KEEP8(150) INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) 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 LRHS, NRHS REAL RHS(LRHS, NRHS) INTEGER MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) REAL RHSCOMP(LRHSCOMP,NRHS) INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER P_UPDATE, P_SOL_MAS, LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER I, JJ, IN, PROCDEST, J1, J2, IFR, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSCOMP 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 DEJA_SEND( 0:SLAVEF-1 ) INTEGER MUMPS_275 EXTERNAL MUMPS_275, strsv, strsm, sgemv, sgemm INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & PTWCB_PANEL, NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS 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, & LONG, 1, MPI_INTEGER, & COMM, IERR) IF ( POSIWCB - LONG - 2 .LT. 0 & .OR. POSWCB - PLEFTW + 1 .LT. LONG ) THEN CALL SMUMPS_95(NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ((POSIWCB - LONG - 2 ) .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG + 2 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1 .LT. LONG ) THEN INFO(1) = -11 INFO(2) = LONG + PLEFTW - POSWCB - 1 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=1,NRHS CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_REAL, COMM, IERR) DO JJ=0, LONG-1 RHS(IWCB(POSIWCB+1+JJ),K) = W(POSWCB+1+JJ) 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_275(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 ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF (KEEP(201).GT.0) THEN CALL SMUMPS_643( & 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 .LT. PLEFTW - 1 ) THEN CALL SMUMPS_95(NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS .LT. PLEFTW - 1 ) THEN INFO(1) = -11 INFO(2) = LONG * NRHS- POSWCB WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + NPIV * NRHS PLEFTW = P_SOL_MAS + NROW_L * NRHS DO K=1, NRHS CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-1)*NROW_L),NROW_L, & MPI_REAL, & COMM, IERR ) ENDDO IF (KEEP(201).EQ.1) THEN IF ( NRHS == 1 ) THEN CALL sgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE CALL sgemm( 'T', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) ENDIF ELSE IF ( NRHS == 1 ) THEN CALL sgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE CALL sgemm( 'N', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) END IF ENDIF IF (KEEP(201).GT.0) THEN CALL SMUMPS_598(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 100 CONTINUE CALL SMUMPS_63( NRHS, INODE, W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS 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 ) 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 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL END IF DO K=1, NRHS CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_REAL, & COMM, IERR ) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0) THEN CALL SMUMPS_643( & 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_755( & 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_690(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 .LT. PLEFTW - 1 ) THEN CALL SMUMPS_95( NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 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 PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = LIELL 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(STEP(INODE)) IFR = PTRACB(STEP( INODE )) DO K=1, NRHS DO JJ = J1, J2 W(IFR+JJ-J1+(K-1)*LIELL) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO END DO IFR = PTRACB(STEP(INODE))-1+NPIV 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 DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*LIELL) = RHS(J,K) ENDDO ENDDO 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_641(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_PANEL = PTRACB(STEP(INODE)) + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL SMUMPS_667(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL SMUMPS_698( & 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 ( NRHS == 1 ) THEN IF (NCB_PANEL.NE.0) THEN CALL sgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( NBJ + PTWCB_PANEL ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ENDIF CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE IF (NCB_PANEL.NE.0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, & A(APOSDEB + int(NBJ,8)), LDAJ, & W(NBJ+PTWCB_PANEL),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ENDIF CALL strsm('L','L','T','U',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) 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 == 1 ) THEN CALL sgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & W(PTRACB(STEP(INODE))), 1 ) ELSE CALL sgemm( 'N', 'N', NPIV, NRHS, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, W(PTRACB(STEP(INODE))),LIELL) END IF ENDIF IF ( NRHS == 1 ) THEN CALL strsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & W(PTRACB(STEP(INODE))),1) ELSE CALL strsm( 'L','U', 'N', 'U', NPIV, NRHS, ONE, & A(APOS), LDA, & W(PTRACB(STEP(INODE))),LIELL) END IF 1234 CONTINUE IF (KEEP(201).GT.0) THEN CALL SMUMPS_598(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 DO I = 1, NPIV JJ = IW( IPOS + I - 1 ) DO K=1,NRHS RHS( JJ, K ) = W( PTRACB(STEP(INODE))+I-1 & + (K-1)*LIELL ) ENDDO END DO 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL SMUMPS_151(NRHS, 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_275(PROCNODE_STEPS(STEP(IN)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_275( PROCNODE_STEPS(STEP(IN)), & SLAVEF ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 110 CALL SMUMPS_78( NRHS, IN, 0, 0, & LIELL, LIELL-KEEP(253), & IW( POSINDICES ) , & W( PTRACB(STEP(INODE))), & PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 110 ELSE IF ( IERR .eq. -2 ) THEN INFO(1) = -17 INFO(2) = LIELL * NRHS * KEEP(35) + & ( LIELL + 2 ) * KEEP(34) GOTO 260 ELSE IF ( IERR .eq. -3 ) THEN INFO(1) = -20 INFO(2) = LIELL * NRHS * KEEP(35) + & ( LIELL + 2 ) * 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_242( DUMMY, 1, MPI_INTEGER, MYID, & COMM, FEUILLE, SLAVEF ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL SMUMPS_151(NRHS, 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_151(NRHS, 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_44( MYID, SLAVEF, COMM ) 270 CONTINUE RETURN END SUBROUTINE SMUMPS_42 SUBROUTINE SMUMPS_641(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_641", & 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_641 SUBROUTINE SMUMPS_286( 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_290( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL SMUMPS_768 (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_156( 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_286 SUBROUTINE SMUMPS_768 (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_768 mumps-4.10.0.dfsg/src/dmumps_part3.F0000644000175300017530000071423011562233066017430 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C RECURSIVE SUBROUTINE DMUMPS_210( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 40 ), KEEP(500) INTEGER(8) KEEP8(150) 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(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(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(max(1,KEEP(13))) INTEGER INTARR(max(1,KEEP(14))) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER 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, ISTCHK, ISTCHK_LOC INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER INTEGER NFRONT INTEGER(8) :: SIZFR INTEGER LDA_SON INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, IROW_SON, & NPIV, NROWS_TO_STACK, II, COLLIST INTEGER(8) :: POSROW, SHIFTCB_SON INTEGER NBCOLS_EFF INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP INTEGER ITMP LOGICAL SAME_PROC, COMPRESSCB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE, TYPESPLIT INTEGER KEEP253_LOC INCLUDE 'mumps_headers.h' INTEGER MUMPS_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_810(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 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_210' 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_275( 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_210' 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_210' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN DO WHILE ( PTRIST(STEP( ISON )) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & PDEST_MASTER_ISON, MAITRE_DESC_BANDE, & 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_47( & 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_210' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) 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_47( & 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) DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .EQ. MYID ) THEN NBPROCFILS(STEP(INODE_PERE)) = & NBPROCFILS(STEP(INODE_PERE)) - 1 IF ( PDEST .EQ. PDEST_MASTER ) THEN NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 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_729(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 (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL DMUMPS_539 & (N, INODE_PERE, 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_123(NELT, FRTPTR, FRTELT, & N, INODE_PERE, 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_47( & 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 (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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE CALL DMUMPS_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_40(N, INODE_PERE, & 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) EXIT ELSE CALL DMUMPS_40(N, INODE_PERE, & 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) 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_210" CALL MUMPS_ABORT() ELSE POSROW = PTRAST(STEP(ISON))+SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL DMUMPS_617(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER GOTO 600 ENDIF ITMP=-9999 IF ( LMAP_LOC-NBROW(1)+1-KEEP253_LOC .NE. 0 ) THEN CALL DMUMPS_618( & 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_757( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF CALL DMUMPS_619(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL DMUMPS_530(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST_S, 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_152(.FALSE., MYID, N, & ISTCHK_LOC, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 ) THEN CALL DMUMPS_507( 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_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL DMUMPS_531 & (N, INODE_PERE, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF END IF END DO 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) 95 CONTINUE IF ( PTRIST(STEP(ISON)) .lt.0 .or. & IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) .GT. N ) 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 CALL DMUMPS_67( 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_210" 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_210" 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_210" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF GO TO 95 END IF END IF END DO ITYPE = MUMPS_330(PROCNODE_STEPS(STEP(ISON)), SLAVEF) IF (KEEP(214) .EQ. 2) THEN CALL DMUMPS_314( 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, ITYPE & ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL DMUMPS_626( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP &) 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_44( MYID, SLAVEF, COMM ) ENDIF RETURN END SUBROUTINE DMUMPS_210 SUBROUTINE DMUMPS_211( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE DMUMPS_COMM_BUFFER 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) 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 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(max(1,KEEP(13))) 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_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER INTARR(max(1,KEEP(14))) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER 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 INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL COMPRESSCB INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_211' 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_211' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_275( & 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_211' 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_47( & 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_211' 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_47( & 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 NBPROCFILS(STEP(INODE_PERE))=NBPROCFILS(STEP(INODE_PERE))-1 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 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_211 ', 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 DO II = 1,NROWS_TO_STACK IROW_SON=PERM(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_47( & 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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_617(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during DMUMPS_211" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253).GT. 0 ) THEN CALL DMUMPS_618( & A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253), & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB, & NELIM+NBROW(1)) ELSE CALL DMUMPS_757(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF CALL DMUMPS_619(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL DMUMPS_530(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST_S, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 ) THEN CALL DMUMPS_507( 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_500( & 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 CALL DMUMPS_67(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_211" 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_211" 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_211" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_211' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_152(.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_44(MYID, SLAVEF, COMM ) RETURN END SUBROUTINE DMUMPS_211 SUBROUTINE DMUMPS_93(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR) USE DMUMPS_LOAD USE DMUMPS_OOC 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 INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZECB, IAPOS, I LOGICAL MOVEPTRAST 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) 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_724( 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_576(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in DMUMPS_576' 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 ELSE POSFAC = POSFAC - SIZECB LRLU = LRLU + SIZECB LRLUS = LRLUS + SIZECB - SIZE_INPLACE ENDIF 500 CONTINUE CALL DMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE,KEEP,KEEP8,LRLU) RETURN END SUBROUTINE DMUMPS_93 SUBROUTINE DMUMPS_314( 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, 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) 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 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) ) 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_729(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 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL DMUMPS_688 & ( 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_731(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL DMUMPS_94( N,KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress Stack_band:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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)) IF(KEEP(201).NE.2)THEN CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLU) ELSE CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI+XXI)=LREQI CALL MUMPS_730(LREQA, IW(POSI+XXR)) CALL MUMPS_730(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXS)=-9999 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_576(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in DMUMPS_576' IERROR=0 GOTO 700 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLU) 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_190(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL DMUMPS_190(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE DMUMPS_314 SUBROUTINE DMUMPS_626( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) IMPLICIT NONE include 'mumps_headers.h' INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB 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_152(.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_626 SUBROUTINE DMUMPS_214( KEEP,KEEP8, & MYID, N, NELT, LNA, NZ, NA_ELT, 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, NZ, NA_ELT INTEGER(8), INTENT(OUT) :: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES 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, DMUMPS_LBUFR_BYTES, DMUMPS_LBUF 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 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 + int(KEEP(13),8) 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 + int(KEEP(14),8) 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 NBRECORDS = min(KEEP(39), NZ) ELSE NBRECORDS = min(KEEP(39), NA_ELT) 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_BYTES = KEEP( 44 ) * KEEP( 35 ) DMUMPS_LBUFR_BYTES = max( DMUMPS_LBUFR_BYTES, & 100000 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF DMUMPS_LBUFR_BYTES = DMUMPS_LBUFR_BYTES & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUFR_BYTES)/100D0) NB_BYTES = NB_BYTES + int(DMUMPS_LBUFR_BYTES,8) DMUMPS_LBUF = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 43 ) * KEEP( 35 )) ) DMUMPS_LBUF = max( DMUMPS_LBUF, 100000 ) DMUMPS_LBUF = DMUMPS_LBUF & + int( 2.0D0 * dble(max(PERLU,0))* & dble(DMUMPS_LBUF)/100D0) DMUMPS_LBUF = max(DMUMPS_LBUF, DMUMPS_LBUFR_BYTES) NB_BYTES = NB_BYTES + int(DMUMPS_LBUF,8) 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 + 5_8 * NSTEPS8 + 3_8 NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI 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_214 SUBROUTINE DMUMPS_757(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_757 SUBROUTINE DMUMPS_618( & 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_618 SUBROUTINE DMUMPS_710 (id, NB_INT,NB_CMPLX ) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 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%POIDS)) NB_INT=NB_INT+size(id%POIDS) 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) 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%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)) & NB_INT=NB_INT+size(id%POSINRHSCOMP) IF (associated(id%MEM_SUBTREE)) & NB_INT=NB_INT+size(id%MEM_SUBTREE) 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%COST_TRAV)) NB_INT=NB_INT+size(id%COST_TRAV) 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) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR) 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%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)) NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA)) 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_CMPLX = NB_CMPLX + NB_REAL RETURN END SUBROUTINE DMUMPS_710 SUBROUTINE DMUMPS_756(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 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 RETURN END SUBROUTINE DMUMPS_756 SUBROUTINE DMUMPS_22( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8, & 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) 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_22", & 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_730(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_632(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL DMUMPS_627(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_627(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_630( 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_724(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_94(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ)) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... alloc_cb', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF DONE = .TRUE. COMP = COMP + 1 ENDIF ENDIF IF (IWPOSCB-IWPOS+1 .LT. LREQ) THEN IF (DONE) GOTO 600 CALL DMUMPS_94(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ)) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... alloc_cb', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF COMP = COMP + 1 IF (IWPOSCB-IWPOS+1 .LT. LREQ) GOTO 600 ENDIF IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in DMUMPS_22",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_22",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_730(LREQCB, IW(IWPOSCB+1+XXR)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF KEEP8(67) = min(LRLUS, KEEP8(67)) #if ! defined(OLD_LOAD_MECHANISM) CALL DMUMPS_471(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #else #if defined (CHECK_COHERENCE) CALL DMUMPS_471(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #else CALL DMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #endif #endif RETURN 600 IFLAG = -8 IERROR = LREQ RETURN 620 IFLAG = -9 CALL MUMPS_731(LREQCB_EFF - LRLUS, IERROR) RETURN END SUBROUTINE DMUMPS_22 SUBROUTINE DMUMPS_244(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) USE DMUMPS_LOAD 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(*) 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 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))) INTEGER INTARR(max(1,KEEP(14))) DOUBLE PRECISION DBLARR(max(1,KEEP(13))) DOUBLE PRECISION SEUIL, SEUIL_LDLT_NIV2 INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INTEGER MUMPS_275 EXTERNAL MUMPS_275 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) 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 IPTRLU = LRLU NTOTPV = 0 NMAXNPIV = 0 IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_362(N, LEAF, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL DMUMPS_506(POOL, LPOOL, LEAF) CALL DMUMPS_555(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_275( PROCNODE_STEPS(STEP(KEEP(38))), SLAVEF ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF CALL DMUMPS_251(N,IW,LIW,A,LA,IW1(NSTK),IW1(NBPROCFILS), & INFO(1),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, INFO(2), 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) POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN KEEP8(31) = POSFAC ENDIF KEEP(32) = IWPOS CALL MUMPS_735(KEEP8(31), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) 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 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), INFO(12), & 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/ & ' --- (12) NUMBER OF OFF DIAGONAL PIVOTS =',I15/ & ' --- (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) 99990 FORMAT(/ ' NUMBER OF MSGS RECVD FOR DYNAMIC LOAD =',I15) END SUBROUTINE DMUMPS_244 SUBROUTINE DMUMPS_269( MYID,KEEP,KEEP8, & 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) 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_22( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, 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_269 SUBROUTINE DMUMPS_270( 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_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, 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) 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_S(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), PTRARW(N), PTRAIW(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) DOUBLE PRECISION DBLARR(max(1,KEEP(13))) 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_275 EXTERNAL numroc, MUMPS_275 IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_275( 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_270" CALL MUMPS_ABORT() ENDIF ENDIF PTLUST_S(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_94( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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_S(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST_S( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_730( LREQA, IW(POSHEAD + XXR)) IW( POSHEAD + XXS )=-9999 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_731(LREQA - LRLUS, IERROR) GOTO 700 END IF CALL DMUMPS_94( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB2 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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_S(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = max(POSFAC-1_8,1_8) PTRFAC (STEP(IROOT)) = max(POSFAC-1_8,1_8) 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) CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) POSHEAD = PTLUST_S( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_730( LREQA, IW(POSHEAD + XXR)) IW( POSHEAD + XXS ) = S_NOTFREE 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 ( KEEP( 50 ) .eq. 0 .OR. KEEP(50) .eq. 2 ) THEN OPELIW = OPELIW + ( dble(2*TOT_ROOT_SIZE) * & dble(TOT_ROOT_SIZE) * dble(TOT_ROOT_SIZE ) / dble(3) & - 0.5d0 * dble( TOT_ROOT_SIZE ) * dble( TOT_ROOT_SIZE ) & - dble( TOT_ROOT_SIZE ) / dble( 6 ) ) & / dble( root%NPROW * root%NPCOL ) ELSE OPELIW = OPELIW + ( dble(TOT_ROOT_SIZE) * & dble( TOT_ROOT_SIZE) * & dble( TOT_ROOT_SIZE + 1 ) ) & / dble( 3 * root%NPROW * root%NPCOL ) END IF 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_756(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL DMUMPS_96( 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_152(.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 ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_681(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL DMUMPS_580(IERR) ENDIF CALL DMUMPS_507( 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_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE DMUMPS_270 SUBROUTINE DMUMPS_96 &( 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_96 INTEGER FUNCTION DMUMPS_505(KEEP,KEEP8) IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) DMUMPS_505 = KEEP(28) + 1 + 3 RETURN END FUNCTION DMUMPS_505 SUBROUTINE DMUMPS_506(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_506 SUBROUTINE DMUMPS_507 & (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_170 LOGICAL MUMPS_170, 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_170(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_514(INODE,1) ENDIF ENDIF IF ( MUMPS_170(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))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)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)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_507 LOGICAL FUNCTION DMUMPS_508(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) DMUMPS_508 = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION DMUMPS_508 SUBROUTINE DMUMPS_509( 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_167, MUMPS_283, DMUMPS_508 LOGICAL MUMPS_167, MUMPS_283, DMUMPS_508 EXTERNAL MUMPS_275 INTEGER MUMPS_275 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 #if defined(POOL_EXTRACT_MNG) INTEGER POS_TO_EXTRACT #endif 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_509: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( DMUMPS_508(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in DMUMPS_509" 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_509" 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_561(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_820(FLAG_MEM) IF(FLAG_MEM)THEN CALL DMUMPS_561(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_167( PROCNODE(STEP(INODE_EFF)), SLAVEF) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL DMUMPS_513(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_283( PROCNODE(STEP(INODE_EFF)), & SLAVEF)) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL DMUMPS_513(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in DMUMPS_509", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL DMUMPS_520 & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_167( PROCNODE(STEP(INODE)), & SLAVEF) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_283( PROCNODE(STEP(INODE)), & SLAVEF)) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL DMUMPS_561(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 defined(POOL_EXTRACT_MNG) IF(KEEP(76).EQ.4)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.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 #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ELSE IF(DEPTH_FIRST_LOAD(STEP(POOL(LPOOL-2-I))).LT. & DEPTH_FIRST_LOAD(STEP(NODE_TO_EXTRACT))) & THEN POS_TO_EXTRACT=I #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ENDIF ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) INODE = NODE_TO_EXTRACT #else INODE = INODE_EFF #endif DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ENDIF IF(KEEP(76).EQ.5)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.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 #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ELSE IF(COST_TRAV(STEP(POOL(LPOOL-2-I))).GT. & COST_TRAV(STEP(NODE_TO_EXTRACT)))THEN POS_TO_EXTRACT=I #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ENDIF ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) INODE = NODE_TO_EXTRACT #else INODE = INODE_EFF #endif DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ENDIF #endif 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_820(FLAG_MEM) IF(FLAG_MEM)THEN CALL DMUMPS_561(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_819(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_514(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_509 SUBROUTINE DMUMPS_552(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_275 EXTERNAL MUMPS_275 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_818(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL DMUMPS_818(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_554(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_819(INODE) #if ! defined(NOT_ATM_POOL_SPECIAL) ELSE ENDIF #endif END SUBROUTINE DMUMPS_552 SUBROUTINE DMUMPS_561(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_167 LOGICAL MUMPS_167 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_552(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_553(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_167(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_819(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_561 SUBROUTINE DMUMPS_574 & ( 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_574 SUBROUTINE DMUMPS_128(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, PTRAR, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & ELTNOD, NSLAVES, & XNODEL, NODEL) IMPLICIT NONE INTEGER N,NELT,LIW,IORD, SIZE_SCHUR, NSLAVES INTEGER PTRAR(N,3), NFSIZ(N), FILS(N), FRERE(N) INTEGER ELTPTR(NELT+1) INTEGER XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) INTEGER ELTVAR(ELTPTR(NELT+1)-1) INTEGER IKEEP(N,3) INTEGER LISTVAR_SCHUR(SIZE_SCHUR) INTEGER INFO(40), ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER ELTNOD(NELT) INTEGER K,I,L1,L2,IWFR,NCMPA,LLIW,IFSON,IN INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER NZ, allocok, ITEMP LOGICAL PROK, NOSUPERVAR INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER OPT_METIS_SIZE, NUMFLAG PARAMETER(OPT_METIS_SIZE = 8, NUMFLAG = 1) INTEGER OPTIONS_METIS(OPT_METIS_SIZE) INTEGER IDUM EXTERNAL MUMPS_197, DMUMPS_130, DMUMPS_131, & DMUMPS_129, DMUMPS_132, & DMUMPS_133, DMUMPS_134, & DMUMPS_199, & DMUMPS_557, DMUMPS_201 #if defined(OLDDFS) EXTERNAL DMUMPS_200 #endif ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW RETURN ENDIF MPRINT= ICNTL(3) PROK = (MPRINT.GT.0) LP = ICNTL(1) MP = ICNTL(3) 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) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) 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) IF ( IORD == 5 ) THEN IF (LIW .LT. N+N+1) THEN INFO(1)= -2002 INFO(2) = LIW RETURN ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2*N ) THEN INFO(1)= -2002 INFO(2) = LIW RETURN END IF ELSE IF ( LIW .LT. 4*N+4 ) THEN INFO(1)= -2002 INFO(2) = LIW RETURN END IF ENDIF #if defined(metis) || defined(parmetis) ENDIF #endif IDUM=0 CALL DMUMPS_258(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_129(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), IW(L1)) ELSE CALL DMUMPS_130(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), 4*N+4, IW(L1)) ENDIF LLIW = max(NZ,N) ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF IF (NOSUPERVAR) THEN CALL DMUMPS_132(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) ELSE CALL DMUMPS_131(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_162(N, LLIW, PTRAR, IWFR, PTRAR(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), PTRAR(1,3), & 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_128",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_23(N, LLIW, PTRAR, IWFR, PTRAR(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), PTRAR(1,3)) ENDIF ELSE #if defined(metis) || defined(parmetis) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS ' ENDIF CALL DMUMPS_129(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), IW(L1)) LLIW = max(NZ,N) ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF CALL DMUMPS_538(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, IW(L2), PTRAR(1,2), & IW(L1), IWFR) OPTIONS_METIS(1) = 0 CALL METIS_NODEND(N, IW(L2), IW2(1), NUMFLAG, OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) 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_133(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, PTRAR(1,2), IW(L1)) LLIW = NZ+N ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF CALL DMUMPS_134(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) 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_128",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL DMUMPS_199(N, PTRAR, IW2, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP) ENDIF #if defined(OLDDFS) CALL DMUMPS_200(N, PTRAR, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else CALL DMUMPS_557(N, PTRAR, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, PTRAR(1,2), & INFO(6), FILS, FRERE, PTRAR(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_201(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_209( 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_510(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 IF ( huge(KEEP8(79)) / K79REF + 1_8 .GE. int(NSLAVES,8) ) THEN KEEP8(79)=huge(KEEP8(79)) ELSE KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF ENDIF IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN CALL DMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0) .AND. (NSLAVES.GE.ICNTL(13))) IF (SPLITROOT) THEN CALL DMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) RETURN 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 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) 90 CONTINUE DEALLOCATE(IW) 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_128 SUBROUTINE DMUMPS_258( 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_258 ***') END SUBROUTINE DMUMPS_258 SUBROUTINE DMUMPS_129(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD, 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 DO I = 1,N NZ = NZ + LEN(I) ENDDO RETURN END SUBROUTINE DMUMPS_129 SUBROUTINE DMUMPS_538(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER LEN(N) INTEGER IPE(N+1) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1 DO I = 1,N IWFR = IWFR + LEN(I) 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_538 SUBROUTINE DMUMPS_132(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER LEN(N) INTEGER IPE(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 DO I = 1,N IWFR = IWFR + LEN(I) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0 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 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_132 SUBROUTINE DMUMPS_133(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD 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 DO I = 1,N NZ = NZ + LEN(I) ENDDO RETURN END SUBROUTINE DMUMPS_133 SUBROUTINE DMUMPS_134(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER IPE(N), LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0 DO I = 1,N IWFR = IWFR + LEN(I) + 1 IPE(I) = IWFR ENDDO IWFR = IWFR + 1 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 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = IPE(I) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0 ENDDO RETURN END SUBROUTINE DMUMPS_134 SUBROUTINE DMUMPS_25( 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 PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 INTEGER ELT, I, K, IPTRI, IPTRR, NVAR INTEGER TYPE_PARALL, ITYPE, IRANK TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_330( PROCNODE(abs(STEP(I))), SLAVEF ) IRANK = MUMPS_275( 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 IPTRI = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI IPTRI = IPTRI + NVAR ENDDO PTRAIW( NELT+1 ) = IPTRI KEEP( 14 ) = IPTRI - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + NVAR*NVAR ENDDO PTRARW( NELT+1 ) = IPTRR ELSE IPTRR = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + (NVAR*(NVAR+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR = 1 DO ELT = 1,NELT NVAR = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + NVAR*NVAR ENDDO PTRARW( NELT+1 ) = IPTRR ELSE IPTRR = 1 DO ELT = 1,NELT NVAR = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + (NVAR*(NVAR+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR ENDIF ENDIF KEEP( 13 ) = IPTRR - 1 RETURN END SUBROUTINE DMUMPS_25 SUBROUTINE DMUMPS_120( N, NELT, ELTPROC, SLAVEF, PROCNODE ) IMPLICIT NONE INTEGER N, NELT, SLAVEF INTEGER PROCNODE( N ), ELTPROC( NELT ) INTEGER ELT, I, ITYPE, MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_330(PROCNODE(I),SLAVEF) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_275(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_120 SUBROUTINE DMUMPS_153(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER FRERE(N), FILS(N), NA(N), NE(N) INTEGER FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER XNODEL(N+1), NODEL(NELNOD) INTEGER TNSTK( N ), IPOOL( N ) INTEGER I, K, IFATH INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN 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 file DMUMPS_153 ' 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 RETURN END SUBROUTINE DMUMPS_153 SUBROUTINE DMUMPS_130(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW 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_315 LP = 6 CALL DMUMPS_315(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_315. 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 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 + LEN(I) ENDDO RETURN END SUBROUTINE DMUMPS_130 SUBROUTINE DMUMPS_131(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER IPE(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + LEN(I) IPE(I) = IWFR ELSE IPE(I) = 0 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_131 SUBROUTINE DMUMPS_315(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_316 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_316(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_315: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I8) END SUBROUTINE DMUMPS_315 SUBROUTINE DMUMPS_316( 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_316 SUBROUTINE DMUMPS_36( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & & NSTK_S,NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER NELT,N,LIW,NSTEPS INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER IFLAG,IERROR,INODE,MAXFRW, & IWPOS, IWPOSCB, COMP INTEGER IDUMMY(1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(NELT+1), PTRAIW(NELT+1), ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER INTARR(max(1,KEEP(14))) DOUBLE PRECISION DBLARR(max(1,KEEP(13))) 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 INCLUDE 'mumps_headers.h' LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER MUMPS_330 EXTERNAL MUMPS_330 INTEGER LP, HS, HF INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) NFRONT8 INTEGER(8) LAELL8, APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) LSTK8, SIZFR8 #if defined(ALLOW_NON_INIT) INTEGER(8) :: JJ8 #endif INTEGER NBPANELS_L, NBPANELS_U, LREQ_OOC INTEGER SIZFI, NCB INTEGER JJ,J1,J2 INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM,JJ1,J3, & IORG, IBROT INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER AINPUT, & AII, 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, SIZE_ELTI INTEGER II, I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) LOGICAL MUMPS_167, SSARBR EXTERNAL MUMPS_167 DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_170 LOGICAL MUMPS_170 NFS4FATHER = -1 ETATASS = 0 COMPRESSCB=.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (LEVEL.NE.1) THEN write(6,*) 'Error1 in mpi51f_niv1 ' 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 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG LREQ_OOC = 0 IF (KEEP(201).EQ.1) THEN CALL DMUMPS_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' 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. IF (KEEP(50).EQ.0) THEN CALL MUMPS_124( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, NFRONT, NFRONT_EFF, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG ) ELSE CALL MUMPS_125( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IF (IFLAG.LT.0) GOTO 300 END IF IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_170(PROCNODE_STEPS(STEP(INODE)), & SLAVEF))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL DMUMPS_190(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 Write(*,*) ' ERROR 1 during ass_niv1_ELT' GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL DMUMPS_691(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_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL DMUMPS_471(SSARBR,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, & LRLU) #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, int(NFRONT -1,8) A(APOS:APOS+JJ8) = ZERO APOS = APOS + NFRONT8 END DO END IF #endif NASS = NASS1 PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST_S(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 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)) LSTK = IW(ISTCHK+KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = IW(ISTCHK + 1+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.LE.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB = & ( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = IW( ISTCHK + 2+KEEP(IXSZ)) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS J1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1) THEN J2 = J1 + 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 J2 = J1 + NELIM - 1 ENDIF OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (J2.GE.J1) THEN DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * NFRONT8 DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 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(J2 - J1 + 1,8) ENDIF CALL DMUMPS_178(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), J2 - J1 + 1, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) END DO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) END DO IF (NELIM .NE. 0) THEN J3 = J3 - 1 DO JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) END DO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP( ISON )) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL DMUMPS_152(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_49( & 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_210( 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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP,KEEP8, 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 & ) IF ( IFLAG .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_71( 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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = INTARR(II) IF (KEEP(50).EQ.0) THEN AINPUT = AII + II - J1 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ=J1,J2 APOS2 = ICT12 + int(INTARR(JJ) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ=II,J2 J = INTARR(JJ) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII) AII = AII + 1 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 JJ=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ELSE DO JJ=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+JJ-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF GOTO 500 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_36' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_36' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8-LRLUS, IERROR) GOTO 500 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_36' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = 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 DURING DMUMPS_36' ENDIF IFLAG = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING DMUMPS_36' ENDIF IFLAG = -13 IERROR = NUMSTK 490 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_36 SUBROUTINE DMUMPS_37( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, & MEM_DISTRIB) USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER NELT, N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER(8) LRLU, IPTRLU, LRLUS, POSFAC, LA INTEGER(8) LAELL8 INTEGER JJ INTEGER IFLAG,IERROR,INODE,MAXFRW, & LPOOL, LEAF, & IWPOS, & IWPOSCB, COMP, SLAVEF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(NELT+1), PTRAIW(NELT+1), ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), STEP(N), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PAMASTER(KEEP(28)), & PTRAST(KEEP(28)) 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) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER INTARR(max(1,KEEP(14))) DOUBLE PRECISION DBLARR(max(1,KEEP(13))) INTEGER MYID, COMM INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF, HF_OLD, NSLAVES_OLD,NCBSON INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC, NBPANELS_L, NBPANELS_U INTEGER NCB INTEGER J1,J2 INTEGER(8) NFRONT8, LAPOS2, POSELT, POSEL1, LDAFS8, & JJ2, IACHK, ICT12, ICT21 #if defined(ALLOW_NON_INIT) INTEGER(8) :: JJ8 #endif INTEGER(8) APOS, APOS2 INTEGER NELIM,LDAFS,JJ1,NPIVS,NCOLS,NROWS, & IORG INTEGER LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER AINPUT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, ISLAVE, PDEST INTEGER ELTI, SIZE_ELTI INTEGER II, ELBEG, NUMELT, I, J, AII LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX logical :: force_cand INTEGER(8) APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NUMORG_SPLIT, TYPESPLIT, & NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER IZERO INTEGER IDUMMY(1) INTEGER PDEST1(1) INTEGER ETATASS PARAMETER( IZERO = 0 ) INTEGER MUMPS_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 INTRINSIC real DOUBLE PRECISION ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = 0.0D0 ) 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) END DO 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_330(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) END IF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO 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 IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) SIZE_TMP_SLAVES_LIST = CAND( SLAVEF+1, INIV2 ) ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_810 (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 265 ENDIF CALL DMUMPS_791 ( & 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_472( 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_790 ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) TMP_SLAVES_LIST (1:SIZE_TMP_SLAVES_LIST) & = CAND (1:SIZE_TMP_SLAVES_LIST, INIV2) CALL DMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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_472( 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_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. IF (KEEP(50).EQ.0) THEN CALL MUMPS_124( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, NFRONT,NFRONT_EFF, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) ELSE CALL MUMPS_125( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IF (IFLAG.LT.0) GOTO 250 ENDIF IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN 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 WRITE(6,*) ' Internal error 2 in fac_ass_elt due', & ' to plitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF CALL MUMPS_ABORT() ELSE CALL DMUMPS_472( 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 JJ=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+JJ)=IW(IOLDPS+HF_OLD+JJ) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO JJ=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+JJ) = IW(IOLDPS+HF_OLD+JJ) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE Write(*,*) ' ERROR 2 during ass_niv2' GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL DMUMPS_691(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST_S(STEP(INODE)) = IOLDPS 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+KEEP(IXSZ)) = NFRONT 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_461(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_533(SLAVEF,CAND(SLAVEF+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_533(SLAVEF,SLAVEF-1, & 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) THEN IF(KEEP(50) .EQ. 2) LAELL8 = LAELL8+int(NASS1,8) ENDIF LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE CALL DMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 CALL DMUMPS_471(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, &LRLU) POSEL1 = POSELT - LDAFS8 #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, LDAFS8 - 1_8 A(APOS:APOS+JJ8) = ZERO APOS = APOS + LDAFS8 END DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN A(APOS:APOS+LDAFS8-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.LE.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) J1 = ISTCHK + HS + NROWS + NPIVS J2 = J1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) IF (KEEP(50).eq.0) THEN DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * LDAFS8 DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1,8) - 1_8) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE 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 CALL DMUMPS_178(A, LA, & POSELT, LDAFS, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), NELIM, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) 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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = INTARR(II) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT = AII + II - J1 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ=J1,J2 APOS2 = ICT12 + int(INTARR(JJ) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI 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) THEN IF (KEEP(50).EQ.2) THEN AINPUT=AII DO JJ=II,J2 J=INTARR(JJ) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))= & max(dble(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT))) ENDIF AINPUT=AINPUT+1 ENDDO ELSE AII = AII + J2 - II + 1 CYCLE ENDIF ELSE AII = AII + J2 - II + 1 CYCLE ENDIF ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ=II,J2 J = INTARR(JJ) 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(AII) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII))) ENDIF AII = AII + 1 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 JJ = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-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) DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & 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_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & IW(PDEST), NFRONT, COMM, IERR) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL DMUMPS_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & IW(PDEST), NFRONT, COMM, IERR) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.) IF ( IFLAG .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST_S(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF END DO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 END DO 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.LE.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_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) IF (PDEST1(1).EQ.MYID) THEN CALL DMUMPS_211( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8, 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 ) IF ( IFLAG .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL DMUMPS_71( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST_S(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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_49( & 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_210( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, 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 & ) IF ( IFLAG .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_71( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST_S(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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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)) END DO GOTO 500 250 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION during assembly' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 GOTO 490 265 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DYNAMIC ALLOCATION during assembly' ENDIF IFLAG = -13 IERROR = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_37' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_37' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8 - LRLUS, IERROR) 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_37' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = 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_37' ENDIF IFLAG = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SENDBUFFER TOO SMALL (2) DURING DMUMPS_37' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECVBUFFER TOO SMALL (2) DURING DMUMPS_37' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 490 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_37 SUBROUTINE DMUMPS_123( & 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), PTRARW(NELT+1), & PTRAIW(NELT+1) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) DOUBLE PRECISION A(LA), & DBLARR(max(1,KEEP(13))) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSELT, APOS2, ICT12, APOS INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,I,J,JPOS,NASS,JJ, & IN,AINPUT,J1,J2,IJROW,ILOC, & ELBEG, NUMELT, ELTI, SIZE_ELTI, IPOS, & IPOS1, IPOS2, AII, II, IELL INTEGER :: K1RHS, K2RHS, JFirstRHS 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 A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = & ZERO 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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = ITLOC(INTARR(II)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT = AII + II - J1 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ = J1, J2 JPOS = ITLOC(INTARR(JJ)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI END DO ELSE IF ( I .EQ. 0 ) THEN AII = AII + J2 - II + 1 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 JJ=II,J2 AII = AII + 1 J = ITLOC(INTARR(JJ)) 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(AII-1) 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(AII-1) 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 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_123 SUBROUTINE DMUMPS_126( & N, NELT, NA_ELT, & COMM, MYID, SLAVEF, & IELPTR_LOC, RELPTR_LOC, & ELTVAR_LOC, ELTVAL_LOC, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NELT, NA_ELT 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 IELPTR_LOC( NELT + 1 ), RELPTR_LOC( NELT + 1 ) INTEGER ELTVAR_LOC( max(1,KEEP(14)) ) DOUBLE PRECISION ELTVAL_LOC( max(1,KEEP(13)) ) 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 STATUS( MPI_STATUS_SIZE ), IERR_MPI INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER RECV_IELTPTR, RECV_RELTPTR INTEGER IELTPTR, RELTPTR, INODE 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, K, NB_REC, IREC INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER IVALPTR 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, DIMENSION( : ), ALLOCATABLE :: ELROOTPOS 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 ) 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 = min(KEEP(39),NA_ELT) 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( ELROOTPOS( 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_276( 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_IELTPTR = 1 RECV_RELTPTR = 1 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR = 1 RELPTR_LOC(1) = 1 DO IEL = 1, NELT IELTPTR = id%ELTPTR( IEL ) SIZEI = id%ELTPTR( IEL + 1 ) - IELTPTR 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 ELROOTPOS( NBELROOT ) = RELTPTR GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL DMUMPS_288( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR ), id%A_ELT( RELTPTR ), & 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_IELTPTR: RECV_IELTPTR + SIZEI - 1 ) & = id%ELTVAR( IELTPTR: IELTPTR + SIZEI - 1 ) RECV_IELTPTR = RECV_IELTPTR + SIZEI IF ( KEEP(52) .ne. 0 ) THEN ELTVAL_LOC( RECV_RELTPTR: RECV_RELTPTR + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR = RECV_RELTPTR + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL DMUMPS_127( & id%ELTVAR(IELTPTR), & id%A_ELT (RELTPTR), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL DMUMPS_127( & id%ELTVAR(IELTPTR), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR = RELTPTR + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC( IEL + 1 ) = RELTPTR ELSE RELPTR_LOC( IEL + 1 ) = RECV_RELTPTR ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP(13) = RELTPTR - 1 ELSE KEEP(13) = RECV_RELTPTR - 1 ENDIF IF ( RELTPTR - 1 .ne. id%NA_ELT ) THEN WRITE(*,*) ' ** ERROR ELT DIST: RELPTR - 1 / id%NA_ELT=', & RELTPTR - 1,id%NA_ELT CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR = 1 RELTPTR = 1 SIZEI = 1 SIZER = 1 CALL DMUMPS_127( & id%ELTVAR(IELTPTR), & id%A_ELT (RELTPTR), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR .eq. IELPTR_LOC( NELT+1 ) & .and. RECV_RELTPTR .eq. RELPTR_LOC( 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_IELTPTR ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR = RECV_IELTPTR + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_DOUBLE_PRECISION, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR ), MSGLEN, & MPI_DOUBLE_PRECISION, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR = RECV_RELTPTR + MSGLEN END SELECT FINI = ( RECV_IELTPTR .eq. IELPTR_LOC( NELT+1 ) & .and. RECV_RELTPTR .eq. RELPTR_LOC( 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_276( 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 IVALPTR = ELROOTPOS( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K = 1 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( IVALPTR + K ) ELSE VAL = id%A_ELT( IVALPTR + K ) * & 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_34( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) END IF K = K + 1 END DO END DO END DO CALL DMUMPS_18( & 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(ELROOTPOS) IF (KEEP(46) .eq. 0 ) THEN DEALLOCATE(RG2LALLOC) ENDIF ENDIF DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE DMUMPS_126 SUBROUTINE DMUMPS_127( & 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_127 SUBROUTINE DMUMPS_213( 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_213 SUBROUTINE DMUMPS_288( 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_288 SUBROUTINE DMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, ICNTL, CNTL, & NZ, IRN, IRNhere, JCN, JCNhere, A, Ahere, & NZ_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 ICNTL(40), INFO(40), INFOG(40) 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) 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(in) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(in) :: 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 DMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (DMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_AFFECT_MAPPING, & MUMPS_AFFECT_PIVNUL_LIST, & MUMPS_AFFECT_SYM_PERM, & MUMPS_AFFECT_UNS_PERM 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%NZ_loc = NZ_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%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) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NZ) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NZ) IF ( Ahere /= 0 ) mumps_par%A => A(1:NZ) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NZ_loc) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NZ_loc) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NZ_loc) 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) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NZ = mumps_par%NZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_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_AFFECT_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_AFFECT_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_AFFECT_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_AFFECT_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF 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-4.10.0.dfsg/src/cmumps_part8.F0000644000175300017530000101764111562233067017440 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE CMUMPS_301( id) USE CMUMPS_STRUC_DEF USE MUMPS_SOL_ES USE CMUMPS_COMM_BUFFER USE CMUMPS_OOC USE TOOLS_COMMON IMPLICIT NONE INTERFACE SUBROUTINE CMUMPS_710( id, NB_INT,NB_CMPLX ) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC) :: id INTEGER(8) :: NB_INT,NB_CMPLX END SUBROUTINE CMUMPS_710 SUBROUTINE CMUMPS_758 &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE CMUMPS_758 END INTERFACE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE (CMUMPS_STRUC), TARGET :: id INTEGER MP,LP, MPG LOGICAL PROK, PROKG INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, ERANAL, GIVSOL INTEGER ICNTL10, ICNTL11 INTEGER I,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK INTEGER LIW INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER LWCB_MIN, LWCB, LWCB_SOL_C INTEGER(8) :: TMP_LWCB8 INTEGER CMUMPS_LBUF, CMUMPS_LBUF_INT INTEGER MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 INTEGER NITREF, NOITER, SOLVET, KASE, JOBIREF COMPLEX RSOL(1) LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 INTEGER :: K220(0:id%NSLAVES) 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 INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, NBT INTEGER :: PERM_PIV_LIST(max(id%KEEP(112),1)) INTEGER :: MAP_PIVNUL_LIST(max(id%KEEP(112),1)) INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS 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 ) COMPLEX, DIMENSION(:), POINTER :: RHS_MUMPS COMPLEX, DIMENSION(:), POINTER :: WORK_WCB COMPLEX, DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER :: LPTR_RHS_ROOT COMPLEX, ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) COMPLEX, ALLOCATABLE :: CWORK(:) REAL, ALLOCATABLE :: R_RW1(:), R_Y(:), D(:) REAL, ALLOCATABLE :: R_W(:) REAL, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 COMPLEX, ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV, & POSINRHSCOMP_N INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) 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 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 REAL, DIMENSION(:), POINTER :: PT_SCALING REAL, TARGET :: Dummy_SCAL(1) 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, WHAT INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & IBEG, LD_RHS, KDEC, & MASTER_ROOT, MASTER_ROOT_IN_COMM INTEGER IPT_RHS_ROOT, SIZE_ROOT, LD_REDRHS INTEGER IBEG_REDRHS, IBEG_RHSCOMP, LD_RHSCOMP, LENRHSCOMP INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES INTEGER(8) NB_BYTES_MAX INTEGER(8) NB_BYTES_EXTRA INTEGER(8) NB_INT, NB_CMPLX, K34_8, K35_8, NB_BYTES_ON_ENTRY INTEGER(8) K16_8, ITMP8 #if defined(V_T) 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 MUMPS_275 EXTERNAL MUMPS_275 #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 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_MUMPS) 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 RINFOG =>id%RINFOG MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LP = id%ICNTL( 1 ) PROK = (MP.GT.0) PROKG = (MPG.GT.0 .and. id%MYID.eq.MASTER) 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) NB_RHSSKIPPED = 0 LSCAL = .FALSE. WORK_WCB_ALLOCATED = .FALSE. ICNTL21 = -99998 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) CALL CMUMPS_710 (id, NB_INT,NB_CMPLX ) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K35_8 NB_BYTES_ON_ENTRY = NB_BYTES NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID .EQ. MASTER) THEN CALL CMUMPS_807(id) id%KEEP(111) = id%ICNTL(25) id%KEEP(248) = id%ICNTL(20) ICNTL21 = id%ICNTL(21) IF (ICNTL21 .ne.0.and.ICNTL21.ne.1) ICNTL21=0 IF ( id%ICNTL(30) .NE.0 ) THEN id%KEEP(237) = 1 ELSE id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN id%KEEP(248)=1 ENDIF IF (id%KEEP(248) .ne.0.and.id%KEEP(248).ne.1) id%KEEP(248)=0 IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN id%KEEP(248) = 0 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN id%KEEP(235) = 0 ENDIF MTYPE = ICNTL( 9 ) 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(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 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(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF ( id%MYID .EQ. MASTER ) THEN 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 IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN 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 IF (KEEP(252).NE.0 .AND. ICNTL(9).NE.1) THEN 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 INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE INFO(2) = 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 IF ( (id%KEEP(237).EQ.0) ) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. ICNTL21==0) THEN CALL CMUMPS_758 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE 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 IF ((id%NZ_RHS.LE.0).AND.(KEEP(237).NE.0)) THEN 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 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 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 IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN IF (PROKG) THEN write(MPG,*)id%MYID, & " Incompatible values for sparse RHS ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 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 CALL CMUMPS_634(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(111) .NE. 0 .AND. id%KEEP(50) .EQ. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: null space not available for unsymmetric matrices' INFO(1) = -37 INFO(2) = 0 GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN 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 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 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 END IF IF (ICNTL21==1) THEN IF ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) THEN 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 (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 IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1) THEN 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 CALL CMUMPS_769(id) END IF IF (id%INFO(1) .LT. 0) GOTO 333 333 CONTINUE CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 IF ((id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0)) THEN CALL MPI_BCAST(id%NZ_RHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (id%NZ_RHS.EQ.0) THEN IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN LIW_PASSED=max(1,KEEP(32)) IF (KEEP(89) .GT. 0) THEN CALL CMUMPS_535( 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 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 IF ( PROKG ) THEN 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 WRITE (MPG, 153) KEEP(252) ENDIF ENDIF GOTO 90 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(111).NE.0)) THEN KEEP(242) = 0 ENDIF ENDIF INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN IF (LP.GT.0) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF NBT = 0 CALL MUMPS_733(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF (NBT.NE.0) THEN DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE id%Step2node(id%STEP(I)) = I ENDDO ENDIF NB_BYTES = NB_BYTES + int(NBT,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + int(NBT,8) * K34_8 ENDIF IF ( I_AM_SLAVE ) & CALL MUMPS_804(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 IF (id%MYID.EQ.MASTER) THEN IF( KEEP(111)==0 .AND. KEEP(248)==1 ) THEN NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) & NRHS_NONEMPTY = NRHS_NONEMPTY+1 ENDDO IF (NRHS_NONEMPTY.LE.0) THEN IF (LP.GT.0) & WRITE(LP,*) 'Internal error : NRHS_NONEMPTY=', & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF BUILD_POSINRHSCOMP = .TRUE. IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN BUILD_POSINRHSCOMP = .FALSE. ENDIF SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_275( & 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 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_275( & 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 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF IF (id%MYID .eq. MASTER) THEN KEEP(84) = ICNTL(27) IF (KEEP(252).NE.0) THEN 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 ENDIF ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (KEEP(201).GT.0) THEN IF (I_AM_SLAVE) THEN IF (KEEP(201).EQ.1 & .AND.KEEP(50).EQ.0 & .AND.KEEP(251).NE.2 & ) THEN OOC_NB_FILE_TYPE=2 ELSE OOC_NB_FILE_TYPE=1 ENDIF ENDIF 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 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 ) ENDIF IF ( I_AM_SLAVE ) THEN NB_K133 = 3 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 LWCB_MIN = NB_K133*KEEP(133)*NBRHS 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 IF (KEEP(201).EQ.0) THEN IF (ITMP8.NE.KEEP8(24)) THEN INFO(1) = -41 INFO(2) = id%LWK_USER GOTO 99 ENDIF ELSE KEEP8(24)=ITMP8 ENDIF MAXS = 0_8 IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_731(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ELSE IF (associated(id%S)) THEN MAXS = KEEP8(23) ELSE IF (KEEP(201).EQ.0) THEN WRITE(*,*) ' Working array S not allocated ', & ' on entry to solve phase (in core) ' CALL MUMPS_ABORT() ELSE IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ENDIF ALLOCATE (id%S(MAXS), stat = allocok) KEEP8(23)=MAXS IF ( allocok .GT. 0 ) THEN WRITE(*,*) ' Problem allocation of S at solve' INFO(1) = -13 CALL MUMPS_731(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) ENDIF ENDIF IF(KEEP(201).EQ.0)THEN LA = KEEP8(31) ELSE LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF IF ( MAXS-LA .GT. int(LWCB_MIN,8) ) THEN TMP_LWCB8 = min( MAXS - LA, int(huge(LWCB),8) ) LWCB = int( TMP_LWCB8, kind(LWCB) ) WORK_WCB => id%S(LA+1_8:LA+TMP_LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB = LWCB_MIN ALLOCATE(WORK_WCB(LWCB_MIN), stat = allocok) IF (allocok < 0 ) THEN INFO(1)=-13 INFO(2)=LWCB_MIN ENDIF WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(size(WORK_WCB),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF 99 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL CMUMPS_590(LA) CALL CMUMPS_586(id) IS_INIT_OOC_DONE = .TRUE. ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF (id%MYID .eq. MASTER) THEN IF ( (KEEP(242).NE.0) .or. (KEEP(243).NE.0) ) THEN IF ( (KEEP(237) .EQ.0) .and. (KEEP(111).EQ.0) ) THEN KEEP(242) = 0 KEEP(243) = 0 ENDIF ENDIF 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 WRITE (MPG, 153) KEEP(252) ENDIF ENDIF LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ERANAL = ((ICNTL(11) .GT. 0) .OR. (ICNTL(10) .GT. 0)) IF ( (KEEP(55).eq.0) .AND. KEEP(54).eq.0 .AND. & .NOT.associated(id%A) ) THEN ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. ELSE ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) ENDIF IF ((KEEP(111).NE.0).OR.(KEEP(237).NE.0).OR. & (KEEP(252).NE.0) ) THEN IF (ICNTL10 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF (ICNTL11 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. END IF IF (KEEP(221).NE.0) THEN IF (ICNTL10 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 (reduced RHS))' ENDIF IF (ICNTL11 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 (reduced RHS)' ENDIF ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. END IF IF ((ERANAL .AND. NBRHS > 1) .OR. ICNTL(21) > 0) THEN IF (ICNTL11 > 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to zero' ICNTL11=0 ENDIF IF (ICNTL10 > 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to zero' ICNTL10=0 ENDIF ERANAL = .FALSE. ENDIF IF (ERANAL) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN WRITE(*,*) ' 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 IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 END IF 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(ERANAL,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) CALL MPI_BCAST(KEEP(242),1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(243),1,MPI_INTEGER,MASTER, & id%COMM,IERR) DO_PERMUTE_RHS = (KEEP(242).NE.0) IF ( KEEP(242).NE.0) THEN IF ((KEEP(237).EQ.0).AND.(KEEP(111).EQ.0)) THEN IF (MP.GT.0) THEN write(MP,*) ' Warning incompatible options ', & ' permute RHS reset to false ' ENDIF DO_PERMUTE_RHS = .FALSE. ENDIF ENDIF IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN 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 #if defined(check) IF ( id%MYID_NODES .EQ. MASTER ) THEN WRITE(*,*) " ES A-1 DO_Perm Interleave =" WRITE(*,144) id%KEEP(235), id%KEEP(237), & id%KEEP(242),id%KEEP(243) ENDIF #endif MSG_MAX_BYTES_SOLVE = ( 4 + KEEP(133) ) * KEEP(34) + & KEEP(133) * NBRHS * KEEP(35) & + 16 * KEEP(34) IF (KEEP(237).EQ.0) THEN 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 MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(35) ) ENDIF 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 (LP.GT.0) & 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 ) THEN CMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL CMUMPS_55( CMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = CMUMPS_LBUF_INT IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF CMUMPS_LBUF = (MSG_MAX_BYTES_SOLVE + 2*KEEP(34) )*id%NSLAVES CMUMPS_LBUF = min(CMUMPS_LBUF, 100 000 000) CMUMPS_LBUF = max(CMUMPS_LBUF, & (MSG_MAX_BYTES_SOLVE+2*KEEP(34)) * min(id%NSLAVES,3)) CMUMPS_LBUF = CMUMPS_LBUF + KEEP(34) CALL CMUMPS_53( CMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = CMUMPS_LBUF/KEEP(34) + 1 IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF ENDIF IF ( & ( id%MYID .NE. MASTER ) & .or. & ( 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. & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) & ) THEN ALLOCATE(RHS_MUMPS(id%N*NBRHS),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_MUMPS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N*NBRHS IF (LP > 0) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' GOTO 111 END IF ELSE RHS_MUMPS=>id%RHS ENDIF IF ( I_AM_SLAVE ) THEN LD_RHSCOMP = max(KEEP(89),1) IF (id%MYID.EQ.MASTER) THEN LD_RHSCOMP = max(LD_RHSCOMP, KEEP(247)) ENDIF IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN IF (.NOT.associated(id%RHSCOMP)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF IF (.NOT.associated(id%POSINRHSCOMP)) THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF LENRHSCOMP = size(id%RHSCOMP) LD_RHSCOMP = LENRHSCOMP/id%NRHS ELSE IF (KEEP(221).EQ.1) THEN IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) ENDIF LENRHSCOMP = LD_RHSCOMP*id%NRHS ALLOCATE (id%RHSCOMP(LENRHSCOMP)) NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) ENDIF ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE LENRHSCOMP = LD_RHSCOMP*NBRHS IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) ENDIF ALLOCATE (id%RHSCOMP(LENRHSCOMP)) NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) ENDIF ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF LIWK_SOLVE = 4 * KEEP(28) + 1 IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE( LIWK_SOLVE), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 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) LIW = KEEP(32) 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) IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) ) THEN ALLOCATE(POSINRHSCOMP_N(id%N), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP.GT.0) WRITE(LP,*) & ' ERROR in CMUMPS_301: allocating POSINRHSCOMP_N' INFO(1) = -13 INFO(2) = id%N GOTO 111 END IF NB_BYTES = NB_BYTES + int(size(POSINRHSCOMP_N),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) END IF ELSE LIW=0 END IF 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) & ) & .OR. ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) & ) 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 DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF 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 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif CALL MUMPS_276( 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 CALL MPI_BCAST(UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN 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 (LP > 0) 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 (LP > 0) 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 LIW_PASSED=max(1,LIW) IF (KEEP(89) .GT. 0) THEN CALL CMUMPS_535( 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 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 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 40 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 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 IF ( ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) THEN 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 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 IF ( id%MYID .EQ. MASTER ) THEN 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 CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF ENDIF ENDIF IF ( KEEP(248)==1 ) THEN JEND_RHS = 0 IF (DO_PERMUTE_RHS) THEN 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 STRAT_PERMAM1 = KEEP(242) CALL MUMPS_780 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF 109 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (id%NSLAVES .EQ. 1) THEN IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF 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 IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_772 & (PERM_RHS, id%NRHS, id%N, id%KEEP(28), & id%PROCNODE_STEPS(1), id%STEP(1), id%NSLAVES, & id%Step2node(1), & IERR) ENDIF ENDIF ENDIF ENDIF IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) 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 ( & ( id%MYID .NE. MASTER ) & .or. & ( 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. & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) & ) THEN LD_RHS = id%N IBEG = 1 ELSE IF ( associated(id%RHS) ) THEN LD_RHS = max(id%LRHS, id%N) ELSE LD_RHS = id%N ENDIF IBEG = (BEG_RHS-1) * LD_RHS + 1 ENDIF JBEG_RHS = BEG_RHS IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 ) THEN JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN DO I=1, id%N RHS_MUMPS((PERM_RHS(JBEG_RHS) -1)*LD_RHS+I) & = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 CYCLE 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 DO I=1, id%N RHS_MUMPS((JBEG_RHS -1)*LD_RHS + I) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN IBEG = (JBEG_RHS-1) * LD_RHS + 1 ENDIF ENDIF CALL MPI_BCAST( JBEG_RHS,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0) THEN IBEG_REDRHS= (JBEG_RHS-1)*LD_REDRHS + 1 ELSE IBEG_REDRHS=-142424 ENDIF IF ( I_AM_SLAVE ) THEN IF ( KEEP(221).EQ.0 ) THEN IBEG_RHSCOMP= 1 ELSE IBEG_RHSCOMP= (JBEG_RHS-1)*LD_RHSCOMP + 1 ENDIF ELSE IBEG_RHSCOMP=-152525 ENDIF #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN IF (KEEP(248)==1) THEN NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 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 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)) & STOP_AT_NEXT_EMPTY_COL =.TRUE. IF (COLSIZE.GT.0) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN NBCOL_INBLOC = NBCOL_INBLOC -1 NBRHS_EFF = NBCOL EXIT ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NBCOL.NE.NBRHS_EFF) THEN WRITE(6,*) 'INTERNAL ERROR 1 in CMUMPS_301 ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF 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) JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 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 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 IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN 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 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) 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 & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN 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 & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY & => 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 RHS_SPARSE_COPY = ONE ELSE IF (.NOT. LSCAL) 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)) 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 ENDIF IF (KEEP(23) .NE. 0) THEN IF (MTYPE .NE. 1) THEN IF (KEEP(248)==0) THEN ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in CMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF DO K = 1, NBRHS_EFF KDEC = IBEG+(K-1)*LD_RHS DO I = 1, id%N C_RW2(I)=RHS_MUMPS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) RHS_MUMPS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ELSE IPOS = 1 DO I=1, NBCOL_INBLOC 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 ENDIF ENDIF IF (ERANAL) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+(K-1)*LD_RHS DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = RHS_MUMPS(KDEC+I-1) END DO ENDDO ENDIF ENDIF IF (LSCAL) THEN IF (KEEP(248)==0) THEN IF (MTYPE .EQ. 1) THEN DO K =1, NBRHS_EFF KDEC = (K-1) * LD_RHS + IBEG - 1 DO I = 1, id%N RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * & id%ROWSCA(I) END DO ENDDO ELSE DO K =1, NBRHS_EFF KDEC = (K-1) * LD_RHS + IBEG - 1 DO I = 1, id%N RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * & id%COLSCA(I) END DO ENDDO ENDIF ELSE KDEC=id%IRHS_PTR(JBEG_RHS) IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN RHS_SPARSE_COPY(IPOS) = id%ROWSCA(PERM_RHS(I)) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE DO K = 1, COLSIZE II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) 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 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 END IF ENDIF #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif 30 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF ( I_AM_SLAVE ) THEN IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) .OR. & (KEEP(252).NE.0) ) THEN IF (BUILD_POSINRHSCOMP) THEN IF (KEEP(111).NE.0) THEN WHAT = 2 MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN WHAT = 0 MTYPE_LOC = 1 ELSE WHAT = 1 MTYPE_LOC = MTYPE ENDIF LIW_PASSED=max(1,LIW) IF (WHAT.EQ.0) THEN CALL CMUMPS_639(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(1), IDUMMY, 1, MTYPE_LOC, & WHAT ) ELSE CALL CMUMPS_639(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(1), POSINRHSCOMP_N(1), & id%N, MTYPE_LOC, & WHAT ) ENDIF BUILD_POSINRHSCOMP = .FALSE. ENDIF ENDIF ENDIF 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(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN 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 #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0)) THEN IF (KEEP(248) == 0) THEN IF ( .NOT.I_AM_SLAVE ) THEN CALL CMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) BUILD_POSINRHSCOMP=.FALSE. ELSE LIW_PASSED = max( LIW, 1 ) CALL CMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), & BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) BUILD_POSINRHSCOMP=.FALSE. ENDIF IF (INFO(1).LT.0) GOTO 90 ELSE CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER) 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. 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) 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 45 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_COMPLEX, & 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 IF ( I_AM_SLAVE ) THEN IF (KEEP(237).NE.0) THEN K=1 RHS_MUMPS(1:NBRHS_EFF*LD_RHS) = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IF (POSINRHSCOMP_N(J).NE.0) THEN RHS_MUMPS((K-1) * LD_RHS + J) = & RHS_SPARSE_COPY(IPOS) ENDIF K = K + 1 IPOS = IPOS + COLSIZE ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'INTERNAL ERROR 2 in CMUMPS_301 ', & K, NBRHS_EFF call MUMPS_ABORT() ENDIF ELSE IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0)) THEN 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 DO K = 1, NBCOL_INBLOC KDEC = (K-1) * LD_RHS + IBEG - 1 RHS_MUMPS(KDEC+1:KDEC+id%N) = ZERO DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IF (POSINRHSCOMP_N(I).NE.0) THEN RHS_MUMPS(KDEC+I)= RHS_SPARSE_COPY(IZ) ENDIF ENDDO ENDDO END IF ENDIF ENDIF ELSE IF (I_AM_SLAVE) THEN IF (KEEP(111).NE.0) THEN 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 IEND_GLOB_DEF = id%KEEP(112) id%KEEP(235) = 1 DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN 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+K35_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN 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 50 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 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) RHS_MUMPS( IBEG : & (IBEG + (NBRHS_EFF)*LD_RHS -1) ) = ZERO ENDIF DO K=1, NBRHS_EFF KDEC = (K-1) *LD_RHSCOMP id%RHSCOMP(KDEC+1:KDEC+LD_RHSCOMP)=ZERO END DO IF ((KEEP(235).NE.0).AND. INTERLEAVE_PAR) THEN DO I=IBEG_GLOB_DEF,IEND_GLOB_DEF IF (id%MYID_NODES .EQ. MAP_PIVNUL_LIST(I) ) THEN JJ= POSINRHSCOMP_N(PERM_PIV_LIST(I)) IF (JJ.GT.LD_RHSCOMP) THEN WRITE(6,*) ' Internal ERROR JJ, LD_RHSCOMP=', & JJ, LD_RHSCOMP ENDIF IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN id%RHSCOMP(IBEG_RHSCOMP -1+ & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = & cmplx(abs(id%DKEEP(2)),kind=kind(id%RHSCOMP)) ELSE id%RHSCOMP(IBEG_RHSCOMP -1+ & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = ONE ENDIF ENDIF ENDIF ENDDO ELSE DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) JJ= POSINRHSCOMP_N(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP & + JJ) = cmplx(id%DKEEP(2),kind=kind(id%RHSCOMP)) ELSE id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP & + JJ) = ONE ENDIF ENDIF ENDDO ENDIF IF ( KEEP(17).NE.0 .and. id%MYID_NODES.EQ.MASTER_ROOT) THEN IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -90999 ENDIF ELSE ENDIF ENDIF IF ( I_AM_SLAVE ) THEN LWCB_SOL_C = LWCB IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN IF ( associated(id%root%RHS_CNTR_MASTER_ROOT) ) THEN PTR_RHS_ROOT => id%root%RHS_CNTR_MASTER_ROOT LPTR_RHS_ROOT = size(id%root%RHS_CNTR_MASTER_ROOT) ELSE LPTR_RHS_ROOT = NBRHS_EFF * SIZE_ROOT IPT_RHS_ROOT = LWCB - LPTR_RHS_ROOT + 1 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1 IPT_RHS_ROOT = LWCB PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT ENDIF ENDIF IF (KEEP(221) .EQ. 2 ) THEN IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE IF ( id%MYID .EQ. MASTER) THEN IF (LD_REDRHS.EQ.SIZE_ROOT) THEN KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 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 II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 ENDIF ENDIF IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF ((id%KEEP(235).EQ.0).and.(id%KEEP(237).EQ.0) ) THEN PRUNED_SIZE_LOADED = 0_8 CALL CMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, & IWCB, LIWCB, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%NA(1),id%LNA,id%NE_STEPS(1), SRW3, MTYPE, & ICNTL(1), 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, id%PROCNODE_STEPS(1), & id%NSLAVES, INFO(1), KEEP(1), KEEP8(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(1), BUILD_POSINRHSCOMP & , 1 , 1 , 1 & , 1 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & ) ELSE IF ((KEEP(235).NE.0).AND.KEEP(221).NE.2.AND. & KEEP(111).EQ.0) THEN DO K=1, NBRHS_EFF DO I=1, LD_RHSCOMP id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO ENDDO ENDDO ELSEIF (KEEP(237).NE.0) THEN DO K=1, NBRHS_EFF DO I=1, LD_RHSCOMP id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO ENDDO ENDDO ENDIF IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF CALL CMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, id%NA(1),id%LNA, & id%NE_STEPS(1), SRW3, MTYPE, ICNTL(1), 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, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1),KEEP(1),KEEP8(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(1), BUILD_POSINRHSCOMP, & NZ_THIS_BLOCK, NBCOL_INBLOC, id%NRHS, & JBEG_RHS , id%Step2node(1), id%KEEP(28), IRHS_SPARSE_COPY(1), & IRHS_PTR_COPY(1), & size(PERM_RHS), PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV & ) ENDIF END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LP.GT.0) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LP.GT.0) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF IF (INFO(1).LT.0) GO TO 90 IF ( KEEP(221) .EQ. 1 ) THEN IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE IF ( id%MYID .EQ. MASTER ) THEN IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 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 II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 ENDIF ENDIF IF ( KEEP(221) .NE. 1 ) THEN IF (ICNTL21 == 0) THEN IF ((.NOT. I_AM_SLAVE).AND.KEEP(237).EQ.0) THEN ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) IF (allocok > 0) THEN ALLOCATE( CWORK(KEEP(247)), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=KEEP(247) ENDIF ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) 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 ( .NOT.I_AM_SLAVE ) THEN IF (KEEP(237).EQ.0) THEN CALL CMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & 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) & ) DEALLOCATE( CWORK ) ELSE CALL CMUMPS_812(id%NSLAVES,id%N, & id%MYID, id%COMM, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) & ,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 & ) ENDIF ELSE IF (KEEP(237).EQ.0) THEN CALL CMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & 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, & id%RHSCOMP(1), LENRHSCOMP, & LSCAL, PT_SCALING(1), size(PT_SCALING) & ) ELSE CALL CMUMPS_812(id%NSLAVES,id%N, & id%MYID, id%COMM, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) & , 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), POSINRHSCOMP_N, & id%N & ) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN 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 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 1 gather sol_driver" CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ELSE 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 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 2 gather sol_driver" CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ENDIF ENDIF ELSE IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) IF ( KEEP(89) .GT. 0 ) THEN CALL CMUMPS_532(id%NSLAVES, & id%N, id%MYID_NODES, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%ISOL_loc(1), & id%SOL_loc(1), 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 ) ENDIF ENDIF ENDIF ENDIF IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN DO I = 1, ICNTL10 write(*,*) 'FIXME: to be implemented' END DO END IF IF (ERANAL) THEN IF ((ICNTL10 .GT. 0) .AND. (ICNTL11 .GT. 0)) THEN IF (id%MYID .EQ. MASTER) THEN GIVSOL = .FALSE. IF (MP .GT. 0) WRITE( MP, 170 ) ALLOCATE(R_RW1(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 776 ENDIF ALLOCATE(C_RW2(id%N),stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 776 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) END IF 776 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL CMUMPS_278( ICNTL(9), id%N, id%NZ, id%A(1), & id%IRN(1), id%JCN(1), & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, & KEEP(1),KEEP8(1) ) ELSE CALL CMUMPS_121( ICNTL(9), id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, & KEEP(1),KEEP8(1) ) ENDIF END IF ELSE CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_COMPLEX, MASTER, & id%COMM, IERR ) ALLOCATE( C_LOCWK54( id%N ), stat =allocok ) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N endif CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL CMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_RW2, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C_RW2 = SAVERHS - C_RW2 ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF NB_BYTES = NB_BYTES - int(size(C_LOCWK54),8)*K35_8 DEALLOCATE( C_LOCWK54 ) ALLOCATE( R_LOCWK54( id%N ), stat =allocok ) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N endif CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NZ_loc .NE. 0 ) THEN CALL CMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1)) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_RW1, & 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 NB_BYTES = NB_BYTES - int(size(R_LOCWK54),8)*K16_8 DEALLOCATE( R_LOCWK54 ) END IF IF ( id%MYID .EQ. MASTER ) THEN CALL CMUMPS_205(ICNTL(9),INFO(1),id%N,id%NZ, & RHS_MUMPS(IBEG), SAVERHS,R_RW1,C_RW2,GIVSOL, & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MP,ICNTL(1), & KEEP(1),KEEP8(1)) NB_BYTES = NB_BYTES - int(size(R_RW1),8)*K16_8 & - int(size(C_RW2),8)*K35_8 DEALLOCATE(R_RW1) DEALLOCATE(C_RW2) END IF END IF IF ( PROK .AND. ICNTL10 .GT. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .GT. 0 ) WRITE( MPG, 270 ) 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( 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 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 NITREF = ICNTL10 JOBIREF= ICNTL11 IF ( PROKG .AND. ICNTL10 .GT. 0 ) & WRITE( MPG, 240) 'MAXIMUM NUMBER OF STEPS =', NITREF DO I = 1, id%N D( I ) = RONE END DO 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 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 22 CONTINUE IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .eq. 0 ) THEN IF (KEEP(55).NE.0) THEN CALL CMUMPS_119(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE IF ( MTYPE .eq. 1 ) THEN CALL CMUMPS_207 & ( id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) ELSE CALL CMUMPS_207 & ( id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) END IF ENDIF ENDIF END IF ELSE IF ( KASE .eq. 0 ) THEN IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL CMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE CALL CMUMPS_207(id%A_loc(1), & id%NZ_loc, 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 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 END IF END IF IF ( id%MYID .eq. MASTER ) THEN ARRET = CNTL(2) IF (ARRET .LT. 0.0E0) THEN ARRET = sqrt(epsilon(0.0E0)) END IF CALL CMUMPS_206(id%NZ,id%N,SAVERHS,RHS_MUMPS(IBEG), & C_Y, D, R_W, C_W, & IW1, KASE,RINFOG(7), & RINFOG(9), JOBIREF, RINFOG(10), NITREF, NOITER, MP, & KEEP(1),KEEP8(1), ARRET ) END IF IF ( KEEP(54) .ne. 0 ) THEN CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) END IF IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .eq. 14 ) THEN IF (KEEP(55).NE.0) THEN CALL CMUMPS_122( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%NA_ELT, id%A_ELT(1), & SAVERHS, RHS_MUMPS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL CMUMPS_208 & (id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), SAVERHS, & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL CMUMPS_208 & (id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), SAVERHS, & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) END IF ENDIF GOTO 22 END IF END IF ELSE IF ( KASE.eq.14 ) THEN CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_COMPLEX, MASTER, & id%COMM, IERR ) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL CMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(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 IF ( I_AM_SLAVE .and. id%NZ_loc .NE. 0 ) THEN CALL CMUMPS_193( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(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) END IF GOTO 22 END IF END IF IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .GT. 0 ) THEN IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF END IF END IF CALL MPI_BCAST( KASE , 1, MPI_INTEGER, MASTER, & id%COMM, IERR) CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) IF ( KASE .GT. 0 ) THEN BUILD_POSINRHSCOMP=.FALSE. IF ( .NOT.I_AM_SLAVE ) THEN CALL CMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, C_Y(1), id%N, 1, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) ELSE LIW_PASSED = max( LIW, 1 ) CALL CMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, C_Y(1), id%N, 1, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), & BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) CALL CMUMPS_245( id%root, id%N, id%S(1), LA_PASSED, & id%IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, C_Y, & id%N, NBRHS_EFF, id%NA(1), id%LNA, id%NE_STEPS(1), SRW3, SOLVET, & ICNTL(1), 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, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(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(1), BUILD_POSINRHSCOMP & , 1 , 1 , 1 & , 1 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & ) END IF IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 IF ( .NOT. I_AM_SLAVE .AND. INFO(1) .GE. 0) THEN ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) IF (allocok > 0) THEN ALLOCATE( CWORK(KEEP(247)), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=KEEP(247) ENDIF ENDIF ENDIF 89 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GO TO 90 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 ) IF ( .NOT. I_AM_SLAVE ) THEN CALL CMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & SOLVET, C_Y, id%N, NBRHS_EFF, & 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, size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING)) DEALLOCATE( CWORK ) ELSE CALL CMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & SOLVET, C_Y, id%N, NBRHS_EFF, & 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, & id%RHSCOMP(1), LENRHSCOMP, & LSCAL, PT_SCALING(1), size(PT_SCALING)) ENDIF GO TO 22 ELSEIF ( KASE .LT. 0 ) THEN INFO( 1 ) = INFO( 1 ) + 8 END IF IF ( id%MYID .eq. MASTER ) THEN NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(D ),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W,D) DEALLOCATE(IW1) ENDIF IF ( PROKG ) THEN IF (NITREF.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, 141 ) 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS &=', NOITER ENDIF ENDIF IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF END IF IF ( PROK .AND. ICNTL10 .GT.0 ) WRITE( MP, 131 ) IF (ICNTL11 .GT. 0) THEN IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL CMUMPS_278( MTYPE, id%N, id%NZ, id%A(1), & id%IRN(1), id%JCN(1), & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) ELSE CALL CMUMPS_121( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) ENDIF END IF ELSE CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_COMPLEX, MASTER, & id%COMM, IERR ) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL CMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_W, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C_W = SAVERHS - C_W ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL CMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_Y, & 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 END IF IF (id%MYID .EQ. MASTER) THEN IF ((MPG .GT. 0) .AND. (NITREF .GT. 0)) WRITE( MPG, 65 ) IF ((MPG .GT. 0) .AND. (NITREF .LE. 0)) WRITE( MPG, 170 ) GIVSOL = .FALSE. CALL CMUMPS_205(MTYPE,INFO(1),id%N,id%NZ,RHS_MUMPS(IBEG), & SAVERHS,R_Y,C_W,GIVSOL, & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) &'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', RINFOG(7) WRITE( MPG, 115 ) &'------(8):---------------------------- (W2)=', RINFOG(8) 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 IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) 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) END IF IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0 .AND. KEEP(237).EQ.0 ) THEN IF ((KEEP(221).NE.1 .AND. ICNTL(9) .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN ALLOCATE( C_RW1( id%N ),stat =allocok ) 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 KDEC = (K-1)*LD_RHS+IBEG-1 DO 70 I = 1, id%N C_RW1(I) = RHS_MUMPS(KDEC+I) 70 CONTINUE DO 80 I = 1, id%N JPERM = id%UNS_PERM(I) RHS_MUMPS( KDEC+JPERM ) = C_RW1( I ) 80 CONTINUE END DO DEALLOCATE( C_RW1 ) END IF END IF IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1 & .and. KEEP(237).EQ.0 ) THEN 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) & (RHS_MUMPS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN BEG_RHS = BEG_RHS + NBRHS_EFF ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF ENDDO IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) & .AND. ( KEEP(237).EQ.0 ) & .AND. ( ICNTL21.EQ.0 ) & .AND. ( KEEP(221) .NE.1 ) & .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 RHS_MUMPS((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 RHS_MUMPS((JBEG_NEW -1)*LD_RHS + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF 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 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 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 JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,LD_RHSCOMP id%RHSCOMP((JBEG_NEW -1)*LD_RHSCOMP + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF id%INFO(26) = int(NB_BYTES_MAX / 1000000_8, 4) CALL MUMPS_243( 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 90 CONTINUE IF (INFO(1) .LT.0 ) THEN ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL CMUMPS_582(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF 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 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(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF CALL CMUMPS_57( IERR ) CALL CMUMPS_59( IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF IF ( & ( & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & .and. ICNTL21.ne.0 ) & .or. & ( KEEP(237).NE.0 ) & ) & THEN IF ( I_AM_SLAVE ) THEN IF (associated(RHS_MUMPS) ) THEN NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 DEALLOCATE(RHS_MUMPS) ENDIF ENDIF ENDIF NULLIFY(RHS_MUMPS) ELSE IF (associated(RHS_MUMPS)) THEN NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) END IF END IF IF (I_AM_SLAVE) THEN IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K35_8 DEALLOCATE(SRW3) ENDIF IF (allocated(POSINRHSCOMP_N)) THEN NB_BYTES = NB_BYTES - int(size(POSINRHSCOMP_N),8)*K34_8 DEALLOCATE(POSINRHSCOMP_N) ENDIF IF (LSCAL .AND. ICNTL21==1) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (associated(id%S).AND.KEEP(201).GT.0) THEN 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 IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) ENDIF IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) NULLIFY(id%POSINRHSCOMP) ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K35_8 DEALLOCATE( WORK_WCB ) ENDIF NULLIFY( WORK_WCB ) ENDIF RETURN 65 FORMAT (//' ERROR ANALYSIS AFTER ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' VECTOR SOLUTION FOR COLUMN ',I12) 115 FORMAT(1X, A44,1P,D9.2) 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, A42,I4) END SUBROUTINE CMUMPS_301 SUBROUTINE CMUMPS_245(root, N, A, LA, IW, LIW, W, LWC, & IWCB,LIWW,RHS,LRHS,NRHS,NA,LNA,NE_STEPS, W2, & MTYPE, ICNTL, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1,LIW1, & PROCNODE_STEPS, SLAVEF, & INFO, KEEP,KEEP8, 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, BUILD_POSINRHSCOMP & , 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 & ) 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 LWC,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 LRHS, NRHS, LRHSCOMP COMPLEX A(LA), W(LWC), RHS(LRHS,NRHS), & W2(KEEP(133)), & RHSCOMP(LRHSCOMP,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP(KEEP(28)) 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 LPTR_RHS_ROOT COMPLEX PTR_RHS_ROOT(LPTR_RHS_ROOT) LOGICAL BUILD_POSINRHSCOMP INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,LPANEL_POS INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB,PTRACB INTEGER MTYPE_LOC 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' EXTERNAL CMUMPS_248, CMUMPS_249 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) 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 INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_808 EXTERNAL :: MUMPS_808 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 NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) PTRACB = PTRICB + KEEP(28) IPOOL = PTRACB + 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 in CMUMPS_245", & 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 ( 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_276(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_276(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_276(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 #if defined(NOT_USED) IF ( KEEP(201).GT.0) THEN CALL CMUMPS_789(KEEP(28), & KEEP(38), KEEP(20) ) ENDIF #endif nb_nodes_RHS = 0 #if defined(check) WRITE(*,*) "NBCOL_INBLOC=",NBCOL_INBLOC WRITE(*,*) "JBEG SIZE=",JBEG_RHS, SIZE(IRHS_PTR) #endif 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_276(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_797( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_797( & .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_809(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_808 & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_802( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) 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_583(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_248(N, A(1), LA, IW(1), LIW, W(1), & LWC, RHS, LRHS, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, & NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP,KEEP8, & 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 & ) 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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(I.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_248(N, A(1), LA, IW(1), LIW, W(1), & LWC, RHS, LRHS, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, & Pruned_SONS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP,KEEP8, & 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 & ) DEALLOCATE(prun_NA) ENDIF BUILD_POSINRHSCOMP = .FALSE. #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM CMUMPS_248,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) 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)) 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 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_798( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_798( & .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_809(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_808 & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_803( & 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_584(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_276(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 ( ( 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 write(6,*) " CPA to be double checked " 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_643( & 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_643', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL CMUMPS_286( 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)) IF(KEEP(201).GT.0)THEN CALL CMUMPS_598(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after CMUMPS_598 ', & 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 defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(111).NE.0) & I_WORKED_ON_ROOT = .FALSE. 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_797( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_797( & .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_809(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_808 & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_802( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL CMUMPS_584(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.SPECIAL_ROOT_REACHED ) THEN PTR_RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO 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_249( N, A, LA, IW, LIW, W(1), LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, & W2, NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, & 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) 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_249( N, A, LA, IW, LIW, W(1), LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, & W2, NE_STEPS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, & 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) ENDIF #if defined(V_T) CALL VTEND(back_soln,ierr) #endif ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N WRITE (MP,99992) IF (N.GT.0) WRITE (MP,99993) (RHS(I,1),I=1,K) IF (N.GT.0.and.NRHS>1) & WRITE (MP,99994) (RHS(I,2),I=1,K) 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_245 SUBROUTINE CMUMPS_521(NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NRHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, & LSCAL, SCALING, LSCALING) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, LCWORK COMPLEX RHS (LRHS, NRHS) 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) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER STATUS(MPI_STATUS_SIZE), IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER SK38, SK20 INTEGER, PARAMETER :: FIN = -1 INTEGER, PARAMETER :: yes = 1 INTEGER, PARAMETER :: no = 0 INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist(:) INTEGER :: ONE_PACK INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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 DO J=1, NRHS DO I=1,N RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDDO ENDIF RETURN ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.0) THEN DO J=1, NRHS IF ( I_AM_SLAVE ) THEN CALL MPI_SEND(RHS(1, J), N, MPI_COMPLEX, MASTER, & GatherSol, COMM, IERR) & ELSE CALL MPI_RECV(RHS(1, J), N, MPI_COMPLEX, & 1, & GatherSol, COMM, STATUS, IERR ) IF (LSCAL) THEN DO I=1,N RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDIF ENDIF ENDDO RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .GE. MAXSurf) THEN ONE_PACK = yes ELSE IF (LCWORK .GE. MAXNPIV_estim) THEN ONE_PACK = no ELSE WRITE(*,*) & "Internal error 2 in CMUMPS_521:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (ONE_PACK .EQ. no .AND. I_AM_SLAVE) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_521:", & TYPE_PARAL, LCWORK, KEEP(246),KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (TYPE_PARAL .EQ. 0) &CALL MPI_BCAST(ONE_PACK, 1, MPI_INTEGER, & MASTER, COMM, IERR) 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_521 ' 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_275(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.AND.LSCAL) & CALL CMUMPS_522 ( ONE_PACK, .TRUE. ) ELSE IF (NPIV.GT.0) & CALL CMUMPS_522 ( ONE_PACK, .FALSE.) ENDIF ENDIF ENDDO CALL CMUMPS_523() 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 (ONE_PACK.EQ.yes) THEN CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV*NRHS, MPI_COMPLEX, & COMM, IERR) IF (LSCAL) THEN DO J=1, NRHS DO I=1,NPIV RHS(IROWlist(I),J)= & CWORK(I+(J-1)*NPIV)*SCALING(IROWlist(I)) ENDDO END DO ELSE DO J=1, NRHS DO I=1,NPIV RHS(IROWlist(I),J)= CWORK(I+(J-1)*NPIV) ENDDO END DO ENDIF ELSE DO J=1,NRHS 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),J)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE DO I=1,NPIV RHS(IROWlist(I),J)=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_522 ( ONE_PACK, SCALE_ONLY ) INTEGER, intent(in) :: ONE_PACK LOGICAL, intent(in) :: SCALE_ONLY INTEGER III IF (SCALE_ONLY) THEN DO II=1,NPIV I=IW(J1+II-1) DO J=1, NRHS RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDDO RETURN ENDIF DO II=1,NPIV I=IW(J1+II-1) DO J=1, NRHS CWORK(II+(J-1)*NPIV) = RHS(I,J) ENDDO ENDDO 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 ) IF (ONE_PACK.EQ.yes) THEN CALL MPI_PACK(CWORK(1), NPIV*NRHS, MPI_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ELSE III = 1 DO J=1,NRHS CALL MPI_PACK(CWORK(III), NPIV, MPI_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) III =III+NPIV ENDDO ENDIF N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL CMUMPS_523() END IF RETURN END SUBROUTINE CMUMPS_522 SUBROUTINE CMUMPS_523() 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_523 END SUBROUTINE CMUMPS_521 SUBROUTINE CMUMPS_812(NSLAVES, N, MYID, COMM, & RHS, LRHS, NRHS, 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_N, LPOS_N ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHS, LPOS_N COMPLEX RHS (LRHS, NRHS) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSCOMP_N(LPOS_N) 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 INTEGER STATUS(MPI_STATUS_SIZE), 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) IF (POSINRHSCOMP_N(I).NE.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHS(I,K)*SCALING(I) ELSE RHS_SPARSE_COPY(IZ)=RHS(I,K) ENDIF ENDIF ENDDO K = K + 1 ENDDO RETURN ENDIF IF (I_AM_SLAVE) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IF (POSINRHSCOMP_N(I).NE.0) THEN RHS_SPARSE_COPY(IZ)=RHS(I,K) ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in CMUMPS_812 ' 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) IF (POSINRHSCOMP_N(II).NE.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 IF (LSCAL) & CALL CMUMPS_813 ( .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_813 ( .FALSE. ) ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL CMUMPS_814() 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_813 ( 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_814() END IF RETURN END SUBROUTINE CMUMPS_813 SUBROUTINE CMUMPS_814() 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_814 END SUBROUTINE CMUMPS_812 SUBROUTINE CMUMPS_535(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_275 EXTERNAL MUMPS_275 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_275( 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_535 SUBROUTINE CMUMPS_532( & SLAVEF, N, MYID_NODES, & MTYPE, RHS, LD_RHS, NRHS, & ISOL_LOC, SOL_LOC, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & scaling_data, LSCAL, NB_RHSSKIPPED) 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, NRHS, LD_RHS INTEGER LSOL_LOC, BEG_RHS, NB_RHSSKIPPED INTEGER ISOL_LOC(LSOL_LOC) COMPLEX SOL_LOC( LSOL_LOC, BEG_RHS+NRHS+NB_RHSSKIPPED-1) COMPLEX RHS( LD_RHS , NRHS) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER JJ, J1, ISTEP, K, JEMPTY, JEND INTEGER IPOS, LIELL, NPIV LOGICAL ROOT COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NRHS-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(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 DO JJ=J1,J1+NPIV-1 K=K+1 IF (NB_RHSSKIPPED.GT.0) & SOL_LOC(K, BEG_RHS:JEMPTY) = ZERO IF (LSCAL) THEN SOL_LOC(K,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(K)*RHS(IW(JJ),1:NRHS) ELSE SOL_LOC(K,JEMPTY+1:JEND) = & RHS(IW(JJ),1:NRHS) ENDIF ENDDO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_532 SUBROUTINE CMUMPS_638 & (NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NRHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP, LENPOSINRHSCOMP, & BUILD_POSINRHSCOMP, ICNTL, INFO) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, LENPOSINRHSCOMP INTEGER ICNTL(40), INFO(40) COMPLEX RHS (LRHS, NRHS) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N), POSINRHSCOMP(LENPOSINRHSCOMP) LOGICAL BUILD_POSINRHSCOMP INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER I, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER STATUS(MPI_STATUS_SIZE), IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER SK38, SK20, IPOSINRHSCOMP INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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) ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_276(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) 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 ) RHS( BUF_INDX(I), K ) = ZERO 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 IF (I_AM_SLAVE) THEN IF (BUILD_POSINRHSCOMP) THEN IPOSINRHSCOMP = 1 POSINRHSCOMP = -9678 ENDIF IF (MYID.NE.MASTER) RHS = ZERO DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(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 (BUILD_POSINRHSCOMP) THEN POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF IF (MYID.NE.MASTER) THEN 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_640() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL CMUMPS_640() ENDIF DEALLOCATE (BUF_INDX, BUF_RHS) RETURN CONTAINS SUBROUTINE CMUMPS_640() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX(I) DO K = 1, NRHS RHS( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO BUF_EFFSIZE = 0 RETURN END SUBROUTINE CMUMPS_640 END SUBROUTINE CMUMPS_638 SUBROUTINE CMUMPS_639 & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP, POSINRHSCOMP_N, LPIRC_N, MTYPE, & WHAT ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID_NODES, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N), POSINRHSCOMP(KEEP(28)) INTEGER LPIRC_N, WHAT, MTYPE INTEGER POSINRHSCOMP_N(LPIRC_N) INTEGER ISTEP INTEGER NPIV INTEGER SK38, SK20, IPOS, LIELL INTEGER JJ, J1 INTEGER IPOSINRHSCOMP INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 IF (WHAT .NE. 0.AND. WHAT.NE.1.AND.WHAT.NE.2) THEN WRITE(*,*) "Internal error in CMUMPS_639" CALL MUMPS_ABORT() ENDIF 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 IPOSINRHSCOMP = 1 POSINRHSCOMP = -9678 IF (WHAT .NE. 0) THEN POSINRHSCOMP_N = 0 ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP IF (WHAT .NE. 0) 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)) ENDIF IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_N(IW(JJ)) = IPOSINRHSCOMP+JJ-J1 END DO ENDIF IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_639 SUBROUTINE CMUMPS_248(N, A, LA, IW, LIW, WCB, LWCB, & RHS, LRHS, NRHS, & PTRICB, IWCB, LIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, BUILD_POSINRHSCOMP, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, & NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, INFO, & KEEP,KEEP8, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE CMUMPS_OOC IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER N, LIW, LWCB, LPOOL, LIWCB, LNA INTEGER SLAVEF, MYLEAF, COMM, MYID INTEGER INFO( 40 ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER LRHS, NRHS COMPLEX A( LA ), RHS( LRHS, NRHS ), WCB( LWCB ) INTEGER 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) ) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSCOMP(KEEP(28)), LRHSCOMP LOGICAL BUILD_POSINRHSCOMP COMPLEX RHSCOMP( LRHSCOMP, NRHS ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGSOU, DUMMY(1) LOGICAL FLAG INTEGER NBFIN, MYROOT INTEGER POSIWCB,POSWCB,PLEFTWCB INTEGER INODE INTEGER RHSCOMPFREEPOS INTEGER I INTEGER III, NBROOT,LEAF LOGICAL BLOQ EXTERNAL MUMPS_275 INTEGER MUMPS_275 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1 IF (BUILD_POSINRHSCOMP) RHSCOMPFREEPOS= 1 DO I = 1, KEEP(28) NSTK_S(I) = NE_STEPS(I) ENDDO PTRICB = 0 CALL MUMPS_362(N, LEAF, NBROOT, MYROOT, MYID, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) NBFIN = SLAVEF IF ( MYROOT .EQ. 0 ) THEN NBFIN = NBFIN - 1 DUMMY(1) = 1 CALL CMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF) END IF MYLEAF = LEAF - 1 III = 1 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL CMUMPS_574 & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF BLOQ = ( ( III .EQ. LEAF ) & ) CALL CMUMPS_303( 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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL CMUMPS_574 & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE CALL CMUMPS_302( 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, RHS, LRHS, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & MYROOT, INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL CMUMPS_150( MYID,COMM,BUFR, & LBUFR,LBUFR_BYTES ) RETURN END SUBROUTINE CMUMPS_248 RECURSIVE SUBROUTINE CMUMPS_323 & ( 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, STEP, PROCNODE_STEPS, & RHS, LRHS & ) USE CMUMPS_OOC USE CMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8) :: LA INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) 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 ) INTEGER LRHS COMPLEX RHS(LRHS, NRHS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, K, JJ INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PTRX, PTRY, PDEST, I INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG EXTERNAL MUMPS_275 INTEGER MUMPS_275 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, & LONG, 1, MPI_INTEGER, COMM, IERR ) 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 .LT. LONG * NRHS) THEN INFO( 1 ) = -11 INFO( 2 ) = PLEFTWCB - POSWCB - 1 + LONG * NRHS 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 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_COMPLEX, COMM, IERR ) DO I = 1, LONG RHS(IWCB(I),K) = RHS(IWCB(I),K) +WCB(PLEFTWCB+I-1) 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 ) PTRY = PLEFTWCB PTRX = PLEFTWCB + NCV * NRHS PLEFTWCB = PLEFTWCB + (NPIV + NCV) * NRHS IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 INFO(2) = -POSWCB + PLEFTWCB -1 GO TO 260 END IF DO K=1, NRHS 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 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_643( & 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 ( NRHS == 1 ) THEN CALL cgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE CALL cgemm( 'N', 'N', NCV, NRHS, NPIV, ALPHA, & A(APOS), NCV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) ENDIF ELSE IF ( NRHS == 1 ) THEN CALL cgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE CALL cgemm( 'T', 'N', NCV, NRHS, NPIV, ALPHA, & A(APOS), NPIV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) ENDIF ENDIF IF (KEEP(201).GT.0) THEN CALL CMUMPS_598(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 PDEST = MUMPS_275( 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 DO I = 1, NCV JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) DO K=1, NRHS RHS(JJ,K)= RHS(JJ,K) + WCB(PTRY+I-1+(K-1)*NCV) ENDDO END DO 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_78( NRHS, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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 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_44( MYID, SLAVEF, COMM ) 270 CONTINUE RETURN END SUBROUTINE CMUMPS_323 SUBROUTINE CMUMPS_302( 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, & RHS, LRHS, NRHS, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & MYROOT, & INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & & ) USE CMUMPS_OOC USE CMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MTYPE INTEGER INODE, LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIWCB, LWCB, LIW, POSWCB, PLEFTWCB, POSIWCB INTEGER(8) :: LA INTEGER N, LPOOL, III, LEAF, NBFIN INTEGER MYROOT INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER LRHS, NRHS COMPLEX WCB( LWCB ), A( LA ) COMPLEX RHS(LRHS, NRHS ), 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(KEEP(28)), LRHSCOMP, RHSCOMPFREEPOS COMPLEX RHSCOMP(LRHSCOMP, NRHS) LOGICAL BUILD_POSINRHSCOMP EXTERNAL cgemv, ctrsv, cgemm, ctrsm, MUMPS_275 INTEGER MUMPS_275 COMPLEX ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0E0,0.0E0), & ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, & IERR, IFR_ini, & IFR, LIELL, JJ, & NELIM, PLEFT, PCB_COURANT, PPIV_COURANT INTEGER IPOSINRHSCOMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG, OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER POSWCB1,POSWCB2 INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, & JFIN, NBJ, NUPDATE_PANEL, & PPIV_PANEL, PCB_PANEL, NBK, TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB INTEGER LDAJ, 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 ) 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_643( & 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_755( & 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 IFR = 0 DO JJ = J1, J3 J = IW( JJ ) IFR = IFR + 1 DO K=1,NRHS RHS_ROOT(IFR+NPIV*(K-1)) = RHS(J,K) END DO END DO 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 DUMMY (1) = 1 CALL CMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF) 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_690( LDAJ_FIRST_PANEL ) ENDIF PLEFT = PLEFTWCB PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + LIELL * NRHS IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 INFO(2) = PLEFTWCB - POSWCB - 1 GO TO 260 END IF IF (KEEP(201).EQ.1) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV DO K=1, NRHS IFR = PPIV_COURANT + (K-1)*LIELL - 1 DO JJ = J1, J3 J = IW(JJ) IFR = IFR + 1 WCB(IFR) = RHS(J,K) ENDDO IF (NCB.GT.0) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR = IFR + 1 WCB(IFR) = RHS(J,K) RHS (J,K) = ZERO ENDDO ENDIF END DO ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV*NRHS IFR = PPIV_COURANT - 1 OMP_FLAG = NRHS.GT.4 IFR_ini = IFR DO 130 JJ = J1, J3 J = IW(JJ) IFR = IFR_ini + (JJ-J1) + 1 DO K=1, NRHS WCB(IFR+(K-1)*NPIV) = RHS(J,K) END DO 130 CONTINUE IFR = PCB_COURANT - 1 IF (NPIV .LT. LIELL) THEN IFR_ini = IFR DO 140 JJ = J3 + 1, J2 J = IW(JJ) IFR = IFR_ini + (JJ-J3) DO K=1, NRHS WCB(IFR+(K-1)*NCB) = RHS(J,K) RHS(J,K)=ZERO ENDDO 140 CONTINUE 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_667(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_698( & 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+J-1 PCB_PANEL = PPIV_PANEL+NBJ APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN IF ( NRHS == 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 CALL ctrsm( 'L','L','N','U', NBJ, NRHS, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF ENDIF ELSE IF (NRHS == 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 CALL ctrsm('L','L','N','N',NBJ, NRHS, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) 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 ( NRHS == 1 ) THEN CALL ctrsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, & WCB(PPIV_COURANT), 1 ) ELSE CALL ctrsm( 'L','U','T','U', NPIV, NRHS, ONE, & A(APOS), NPIV, WCB(PPIV_COURANT), & NPIV ) ENDIF ELSE IF ( MTYPE .eq. 1 ) THEN IF ( NRHS == 1) THEN CALL ctrsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE CALL ctrsm( 'L','U','T','U', NPIV, NRHS, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV ) ENDIF ELSE IF (NRHS == 1) THEN CALL ctrsv( 'L', 'N', 'N', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE CALL ctrsm('L','L','N','N',NPIV, NRHS, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV) 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 ( NRHS == 1 ) THEN CALL cgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), & NPIV, WCB(PPIV_COURANT), 1, ONE, & WCB(PCB_COURANT), 1) ELSE CALL cgemm('T', 'N', NUPDATE, NRHS, NPIV, ALPHA, & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) END IF ELSE IF ( NRHS == 1 ) THEN CALL cgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), & LIELL, WCB(PPIV_COURANT), 1, & ONE, WCB(PCB_COURANT), 1 ) ELSE CALL cgemm('N', 'N', NUPDATE, NRHS, NPIV, ALPHA, & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) END IF END IF END IF END IF IF (BUILD_POSINRHSCOMP) THEN POSINRHSCOMP(STEP(INODE)) = RHSCOMPFREEPOS RHSCOMPFREEPOS = RHSCOMPFREEPOS + NPIV ENDIF IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) IF ( KEEP(50) .eq. 0 ) THEN DO K=1,NRHS IFR = PPIV_COURANT + (K-1)*LD_WCBPIV RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = & WCB(IFR:IFR+NPIV-1) ENDDO ELSE IFR = PPIV_COURANT - 1 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 DO IF(JJ .GT. J3) EXIT IFR = IFR + 1 IF(IW(JJ+LIELL) .GT. 0) THEN DO K=1, NRHS RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR+(K-1)*LD_WCBPIV ) * A( APOS1 ) 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 DO K=1, NRHS POSWCB1 = IFR+(K-1)*LD_WCBPIV POSWCB2 = POSWCB1+1 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = WCB(POSWCB1)*A(APOS1) & + WCB(POSWCB2)*A(APOSOFF) RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A(APOSOFF) & + WCB(POSWCB2)*A(APOS2) 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 IFR = IFR+1 ENDIF ENDDO END IF IF (KEEP(201).GT.0) THEN CALL CMUMPS_598(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 IF ( MYROOT .EQ. 0 ) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN DUMMY (1) = 1 CALL CMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF) ENDIF END IF GO TO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN IF (MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 DO 190 I = 1, NUPDATE DO K=1, NRHS RHS( IW(J3 + I), K ) = RHS( IW(J3 + I), K ) & + WCB(PCB_COURANT + I-1 +(K-1)*LD_WCBCB) ENDDO 190 CONTINUE 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_78( NRHS, INODE, FPERE, NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), & MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), SLAVEF), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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_49( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CALL CMUMPS_72( NRHS, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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*KEEP(35) + & ( Effective_CB_Size + 4 ) * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS*KEEP(35) + & ( Effective_CB_Size + 4 ) * KEEP( 34 ) GOTO 260 END IF END DO END IF PLEFTWCB = PLEFTWCB - LIELL*NRHS 270 CONTINUE RETURN 260 CONTINUE CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE CMUMPS_302 RECURSIVE SUBROUTINE CMUMPS_303( 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, STEP, PROCNODE_STEPS, & RHS, LRHS & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB INTEGER LIW INTEGER(8) :: LA INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) 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)) INTEGER LRHS COMPLEX RHS(LRHS, NRHS) LOGICAL FLAG INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) INTEGER MSGSOU, MSGTAG, MSGLEN 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 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_44( MYID, SLAVEF, COMM ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL CMUMPS_323( 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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) END IF END IF RETURN END SUBROUTINE CMUMPS_303 SUBROUTINE CMUMPS_249(N, A, LA, IW, LIW, W, LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , TO_PROCESS, SIZE_TO_PROCESS & ) USE CMUMPS_OOC USE CMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER N,LIW,LIWW,LWC,LPOOL,LNA INTEGER SLAVEF,MYLEAF,COMM,MYID INTEGER LPANEL_POS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NA(LNA),NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER PANEL_POS(LPANEL_POS) INTEGER INFO(40) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)),PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LRHS, NRHS COMPLEX A(LA), RHS(LRHS,NRHS), 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(KEEP(28)) COMPLEX RHSCOMP(LRHSCOMP,NRHS) INTEGER LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) INTEGER MUMPS_275 EXTERNAL MUMPS_275 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INTEGER POSIWCB,POSWCB,K INTEGER(8) :: APOS, IST INTEGER NPIV INTEGER IPOS,LIELL,NELIM,IFR,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 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 INTEGER DUMMY(1) INTEGER 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 LOGICAL DEJA_SEND( 0:SLAVEF-1 ) INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & PTWCB_PANEL, NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL LOGICAL MUMPS_170 INTEGER MUMPS_330 EXTERNAL cgemv, ctrsv, ctrsm, cgemm, & MUMPS_330, & MUMPS_170 PLEFTW = 1 POSIWCB = LIWW POSWCB = LWC NROOT = 0 NBLEAF = NA(1) NBROOT = NA(2) DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_275(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_275(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_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, & SLAVEF) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) THEN GOTO 340 ENDIF ENDIF 50 CONTINUE BLOQ = ( ( III .EQ. IIPOOL ) & ) CALL CMUMPS_41( 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) 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 60 CONTINUE 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 DO JJ = J1, J2 J = IW( JJ ) IFR = IFR + 1 DO K=1,NRHS RHS(J,K) = RHS_ROOT(IFR+NPIV*(K-1)) END DO END DO 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)), & SLAVEF) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CALL CMUMPS_78( NRHS, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1 ), PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = LONG * KEEP(35) + & ( LONG + 2 ) * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = LONG * KEEP(35) + & ( LONG + 2 ) * 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_170( & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) TYPENODE = MUMPS_330(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 - NCB*NRHS .LT. PLEFTW - 1 ) THEN CALL CMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - NCB*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = NCB * NRHS - POSWCB - PLEFTW + 1 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 - NCB*NRHS PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = NCB 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 DO JJ = J1, J2 - KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*NCB) = RHS(J,K) ENDDO ENDDO IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1 DO K=1, NRHS IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+(K-1)*NCB) = ALPHA ELSE W(IFR+(K-1)*NCB) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL CMUMPS_63(NRHS, INODE, & W(Offset+PTRACB(STEP(INODE))), EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL CMUMPS_151(NRHS,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) IPOS = IPOS + 1 IF (KEEP(201).GT.0) THEN CALL CMUMPS_643( & 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_690( LIELL ) IF (KEEP(50).NE.1) THEN CALL CMUMPS_755( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL END IF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. LIELL*NRHS ) THEN CALL CMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. LIELL*NRHS ) THEN INFO(1) = -11 INFO(2) = LIELL*NRHS - POSWCB GOTO 330 END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN CALL CMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 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 - LIELL*NRHS PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = LIELL 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 (KEEP(252).EQ.0) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) DO K=1, NRHS IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-1)*LIELL) = ZERO ENDDO ELSE DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-1)*LIELL) = RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO ENDIF END DO IFR = PTWCB + NPIV - 1 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 DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*LIELL) = RHS(J,K) ENDDO ENDDO IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1 DO K=1, NRHS IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+(K-1)*LIELL) = ALPHA ELSE W(IFR+(K-1)*LIELL) = 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_641(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 + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN CALL CMUMPS_667(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_698( & 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 ( NRHS == 1 ) THEN IF (NCB_PANEL.NE.0) THEN CALL cgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( NBJ + PTWCB_PANEL ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ENDIF IF (MTYPE.NE.1) THEN CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL ctrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ENDIF ELSE IF (NCB_PANEL.NE.0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(NBJ+PTWCB_PANEL),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ENDIF IF (MTYPE.NE.1) THEN CALL ctrsm('L','L','T','U',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE CALL ctrsm('L','L','T','N',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) 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 (NRHS == 1) THEN CALL cgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(NPIV + PTWCB), 1, & ONE, & W(PTWCB), 1 ) ELSE CALL cgemm('T','N', NPIV, NRHS, NCB, ALPHA, A(IST), LIELL, & W(NPIV+PTWCB), LIELL, ONE, & W(PTWCB), LIELL) 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 ( NRHS == 1 ) THEN CALL cgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( NPIV + PTWCB ), & 1, ONE, & W(PTWCB), 1 ) ELSE CALL cgemm( 'N', 'N', NPIV, NRHS, NCB, ALPHA, & A(IST), NPIV, W(NPIV+PTWCB),LIELL, & ONE, W(PTWCB),LIELL) END IF END IF ENDIF IF ( MTYPE .eq. 1 ) THEN IF ( NRHS == 1 ) THEN CALL ctrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL ctrsm('L','L','T','N', NPIV, NRHS, ONE, A(APOS), & LIELL, W(PTWCB), LIELL) ENDIF ELSE IF ( KEEP(50) .EQ. 0 ) THEN IF ( NRHS == 1 ) THEN CALL ctrsv('U','N','U', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL ctrsm('L','U','N','U', NPIV, NRHS, ONE, A(APOS), & LIELL,W(PTWCB),LIELL) END IF ELSE IF ( NRHS == 1 ) THEN CALL ctrsv('U','N','U', NPIV, A(APOS), NPIV, & W(PTWCB), 1) ELSE CALL ctrsm('L','U','N','U',NPIV, NRHS, ONE, A(APOS), & NPIV, W(PTWCB), LIELL) END IF END IF END IF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF DO 150 I = 1, NPIV JJ = IW(J1 + I - 1) DO K=1, NRHS RHS(JJ, K) = W(PTWCB+I-1+(K-1)*LIELL) ENDDO 150 CONTINUE 160 CONTINUE IF (KEEP(201).GT.0) THEN CALL CMUMPS_598(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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_275(PROCNODE_STEPS(STEP(IF)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL CMUMPS_78( NRHS, IF, 0, 0, LIELL, & LIELL - KEEP(253), & IW( POSINDICES ), & W ( PTRACB(STEP( INODE ))), PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NPIV * KEEP(35) + 2 * 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_151(NRHS,N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF GOTO 50 330 CONTINUE CALL CMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, & SLAVEF) 340 CONTINUE CALL CMUMPS_150( MYID,COMM,BUFR, & LBUFR,LBUFR_BYTES ) RETURN END SUBROUTINE CMUMPS_249 RECURSIVE SUBROUTINE CMUMPS_41( & 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, RHS, & LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER LWC COMPLEX W( LWC ) INTEGER POSIWCB, POSWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(40) INTEGER PLEFTW, KEEP( 500) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) COMPLEX A( LA ), W2( KEEP(133) ) INTEGER LRHS, NRHS COMPLEX RHS(LRHS, NRHS) INTEGER MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) COMPLEX RHSCOMP(LRHSCOMP,NRHS) INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER STATUS( MPI_STATUS_SIZE ), IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN 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_44( MYID, SLAVEF, COMM ) ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL CMUMPS_42( 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) END IF END IF RETURN END SUBROUTINE CMUMPS_41 RECURSIVE SUBROUTINE CMUMPS_42( & 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) USE CMUMPS_OOC USE CMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER LWC COMPLEX W( LWC ) INTEGER POSIWCB, POSWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(40) INTEGER PLEFTW, KEEP( 500) INTEGER(8) KEEP8(150) INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) 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 LRHS, NRHS COMPLEX RHS(LRHS, NRHS) INTEGER MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) COMPLEX RHSCOMP(LRHSCOMP,NRHS) INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER P_UPDATE, P_SOL_MAS, LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER I, JJ, IN, PROCDEST, J1, J2, IFR, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSCOMP 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 DEJA_SEND( 0:SLAVEF-1 ) INTEGER MUMPS_275 EXTERNAL MUMPS_275, ctrsv, ctrsm, cgemv, cgemm INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & PTWCB_PANEL, NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS 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, & LONG, 1, MPI_INTEGER, & COMM, IERR) IF ( POSIWCB - LONG - 2 .LT. 0 & .OR. POSWCB - PLEFTW + 1 .LT. LONG ) THEN CALL CMUMPS_95(NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ((POSIWCB - LONG - 2 ) .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG + 2 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1 .LT. LONG ) THEN INFO(1) = -11 INFO(2) = LONG + PLEFTW - POSWCB - 1 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=1,NRHS CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_COMPLEX, COMM, IERR) DO JJ=0, LONG-1 RHS(IWCB(POSIWCB+1+JJ),K) = W(POSWCB+1+JJ) 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_275(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 ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF (KEEP(201).GT.0) THEN CALL CMUMPS_643( & 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 .LT. PLEFTW - 1 ) THEN CALL CMUMPS_95(NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS .LT. PLEFTW - 1 ) THEN INFO(1) = -11 INFO(2) = LONG * NRHS- POSWCB WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + NPIV * NRHS PLEFTW = P_SOL_MAS + NROW_L * NRHS DO K=1, NRHS CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-1)*NROW_L),NROW_L, & MPI_COMPLEX, & COMM, IERR ) ENDDO IF (KEEP(201).EQ.1) THEN IF ( NRHS == 1 ) THEN CALL cgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE CALL cgemm( 'T', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) ENDIF ELSE IF ( NRHS == 1 ) THEN CALL cgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE CALL cgemm( 'N', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) END IF ENDIF IF (KEEP(201).GT.0) THEN CALL CMUMPS_598(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 100 CONTINUE CALL CMUMPS_63( NRHS, INODE, W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS 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 ) 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 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL END IF DO K=1, NRHS CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_COMPLEX, & COMM, IERR ) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0) THEN CALL CMUMPS_643( & 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_755( & 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_690(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 .LT. PLEFTW - 1 ) THEN CALL CMUMPS_95( NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 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 PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = LIELL 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(STEP(INODE)) IFR = PTRACB(STEP( INODE )) DO K=1, NRHS DO JJ = J1, J2 W(IFR+JJ-J1+(K-1)*LIELL) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO END DO IFR = PTRACB(STEP(INODE))-1+NPIV 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 DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*LIELL) = RHS(J,K) ENDDO ENDDO 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_641(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_PANEL = PTRACB(STEP(INODE)) + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL CMUMPS_667(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL CMUMPS_698( & 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 ( NRHS == 1 ) THEN IF (NCB_PANEL.NE.0) THEN CALL cgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( NBJ + PTWCB_PANEL ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ENDIF CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE IF (NCB_PANEL.NE.0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, & A(APOSDEB + int(NBJ,8)), LDAJ, & W(NBJ+PTWCB_PANEL),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ENDIF CALL ctrsm('L','L','T','U',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) 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 == 1 ) THEN CALL cgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & W(PTRACB(STEP(INODE))), 1 ) ELSE CALL cgemm( 'N', 'N', NPIV, NRHS, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, W(PTRACB(STEP(INODE))),LIELL) END IF ENDIF IF ( NRHS == 1 ) THEN CALL ctrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & W(PTRACB(STEP(INODE))),1) ELSE CALL ctrsm( 'L','U', 'N', 'U', NPIV, NRHS, ONE, & A(APOS), LDA, & W(PTRACB(STEP(INODE))),LIELL) END IF 1234 CONTINUE IF (KEEP(201).GT.0) THEN CALL CMUMPS_598(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 DO I = 1, NPIV JJ = IW( IPOS + I - 1 ) DO K=1,NRHS RHS( JJ, K ) = W( PTRACB(STEP(INODE))+I-1 & + (K-1)*LIELL ) ENDDO END DO 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL CMUMPS_151(NRHS, 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_275(PROCNODE_STEPS(STEP(IN)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_275( PROCNODE_STEPS(STEP(IN)), & SLAVEF ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 110 CALL CMUMPS_78( NRHS, IN, 0, 0, & LIELL, LIELL-KEEP(253), & IW( POSINDICES ) , & W( PTRACB(STEP(INODE))), & PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 110 ELSE IF ( IERR .eq. -2 ) THEN INFO(1) = -17 INFO(2) = LIELL * NRHS * KEEP(35) + & ( LIELL + 2 ) * KEEP(34) GOTO 260 ELSE IF ( IERR .eq. -3 ) THEN INFO(1) = -20 INFO(2) = LIELL * NRHS * KEEP(35) + & ( LIELL + 2 ) * 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_242( DUMMY, 1, MPI_INTEGER, MYID, & COMM, FEUILLE, SLAVEF ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL CMUMPS_151(NRHS, 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_151(NRHS, 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_44( MYID, SLAVEF, COMM ) 270 CONTINUE RETURN END SUBROUTINE CMUMPS_42 SUBROUTINE CMUMPS_641(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_641", & 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_641 SUBROUTINE CMUMPS_286( 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_290( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL CMUMPS_768 (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_156( 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_286 SUBROUTINE CMUMPS_768 (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_768 mumps-4.10.0.dfsg/src/cmumps_ooc.F0000644000175300017530000035524711562233067017170 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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 #if defined (NEW_PREF_SCHEME) INTEGER,SAVE :: MAX_PREF_SIZE #endif & ,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_575,CMUMPS_576, & CMUMPS_577, & CMUMPS_578, & CMUMPS_579, & CMUMPS_582, & CMUMPS_583,CMUMPS_584, & CMUMPS_585,CMUMPS_586 INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC CMUMPS_688, & CMUMPS_690 PRIVATE CMUMPS_695, & CMUMPS_697 CONTAINS SUBROUTINE CMUMPS_711( 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_711 FUNCTION CMUMPS_579(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL CMUMPS_579 CMUMPS_579=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION CMUMPS_579 SUBROUTINE CMUMPS_590(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE CMUMPS_590 SUBROUTINE CMUMPS_575(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*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 CALL CMUMPS_588(id,IERR) 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_796(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_711( 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_669(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_589(TMP_DIR(1), & id%OOC_TMPDIR, TMPDIR_MAX_LENGTH, DIM_DIR ) CALL CMUMPS_589(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,kind=4)+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_575 SUBROUTINE CMUMPS_576(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_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_678 & (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_707(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_707(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_689(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_576 SUBROUTINE CMUMPS_577(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE COMPLEX DEST INTEGER ASYNC LOGICAL IO_C #if defined(OLD_READ) INTEGER REQUEST #endif 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. #if ! defined(OLD_READ) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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 #else OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) 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 ) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_READ_OOC' ENDIF RETURN 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 #endif 555 CONTINUE IF(.NOT.CMUMPS_727())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_728() ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_577 SUBROUTINE CMUMPS_591(IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL CMUMPS_675(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE CMUMPS_591 SUBROUTINE CMUMPS_592(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_659() 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_613(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_592 SUBROUTINE CMUMPS_588(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*1 TMP_NAME(350) IERR=0 K=1 IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,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 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_588 SUBROUTINE CMUMPS_587(id,IERR) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC), TARGET :: id INTEGER IERR IERR=0 CALL CMUMPS_588(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_587 SUBROUTINE CMUMPS_586(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_275 INTEGER MUMPS_275 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_VADDR) ENDIF CALL MUMPS_796(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_614(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_586' 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_711( 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_586' id%INFO(1) = -11 CALL MUMPS_731(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_586' 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_586' 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_586' 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_586' 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_275( & 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_275( & 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 #if defined (NEW_PREF_SCHEME) MAX_PREF_SIZE=(1024*1024*2)/8 #endif RETURN END SUBROUTINE CMUMPS_586 SUBROUTINE CMUMPS_585(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_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL CMUMPS_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_585 SUBROUTINE CMUMPS_594(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA COMPLEX A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL CMUMPS_603(ZONE) IERR=0 CALL CMUMPS_611(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE CMUMPS_594 SUBROUTINE CMUMPS_595(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_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_597(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL CMUMPS_597(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_596(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE CMUMPS_595 SUBROUTINE CMUMPS_596(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_330,MUMPS_275 INTEGER MUMPS_330,MUMPS_275 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_330(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_275( & 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_330(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_275( & 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_596 SUBROUTINE CMUMPS_597(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_596(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_597',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_597',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_597 ',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_597 SUBROUTINE CMUMPS_598(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_598', & 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_600(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_608(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_601(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_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL CMUMPS_603(ZONE) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_598 FUNCTION CMUMPS_726(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_726 IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN CMUMPS_726=OOC_NODE_PERMUTED ELSE CMUMPS_726=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.CMUMPS_727())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_728() 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_596(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL CMUMPS_599(INODE,PTRFAC,NSTEPS) IF(.NOT.CMUMPS_727())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_728() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN CMUMPS_726=OOC_NODE_PERMUTED ELSE CMUMPS_726=OOC_NODE_NOT_PERMUTED ENDIF ELSE CMUMPS_726=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION CMUMPS_726 SUBROUTINE CMUMPS_682(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_682 SUBROUTINE CMUMPS_599(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_610(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_609(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE CMUMPS_599 SUBROUTINE CMUMPS_600(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_600 SUBROUTINE CMUMPS_601(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE CMUMPS_601 SUBROUTINE CMUMPS_603(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_603 SUBROUTINE CMUMPS_578(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_608(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_606(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(CMUMPS_579(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL CMUMPS_604(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_606(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL CMUMPS_605(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL CMUMPS_605(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL CMUMPS_604(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_606(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL CMUMPS_608(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_606(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_578 SUBROUTINE CMUMPS_604(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_604', & 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_596( & 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_604' 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_604' 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_604 SUBROUTINE CMUMPS_605(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_605', & 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_596( & 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_605' 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_605' 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_596( & 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_605' 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_605 SUBROUTINE CMUMPS_606(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_606 SUBROUTINE CMUMPS_607(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_607' 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_607 SUBROUTINE CMUMPS_608(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_608',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_596( & 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_596( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' CMUMPS_608',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_596( & 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_608 SUBROUTINE CMUMPS_609(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_609' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_610(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_609 SUBROUTINE CMUMPS_610(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_610 FUNCTION CMUMPS_727() IMPLICIT NONE LOGICAL CMUMPS_727 CMUMPS_727=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN CMUMPS_727=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN CMUMPS_727=.TRUE. ENDIF ENDIF RETURN END FUNCTION CMUMPS_727 SUBROUTINE CMUMPS_611(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_727())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_727())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL CMUMPS_728() 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_727())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL CMUMPS_728() 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_604(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_605(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_605(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_604(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_608(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL CMUMPS_602(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_595(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE CMUMPS_611 SUBROUTINE CMUMPS_602(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_727())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_602',FLAG CALL MUMPS_ABORT() ENDIF CALL CMUMPS_728() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 #if defined (NEW_PREF_SCHEME) IF(MAX_SIZE.GT.MAX_PREF_SIZE)THEN MAX_SIZE=MIN(MAX(MAX_PREF_SIZE, & SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE)), & MAX_SIZE) ENDIF #endif 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_602 SUBROUTINE CMUMPS_582(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_582 SUBROUTINE CMUMPS_612(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_600(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).OR.(J.NE.SPECIAL_ROOT_NODE) & .OR.(ZONE.NE.NB_Z))THEN CALL CMUMPS_599(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.ALREADY_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_599(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_608(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_608 =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_612 SUBROUTINE CMUMPS_583(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_808 EXTERNAL MUMPS_808 IERR = 0 OOC_FCT_TYPE=MUMPS_808("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_612(PTRFAC,NSTEPS,A,LA) ELSE CALL CMUMPS_683(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL CMUMPS_585(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE CMUMPS_583 SUBROUTINE CMUMPS_584(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_808 EXTERNAL MUMPS_808 IERR=0 OOC_FCT_TYPE=MUMPS_808("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_612(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT) THEN CALL CMUMPS_598 ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN CALL CMUMPS_600(IROOT, & ZONE,PTRFAC,NSTEPS) IF(IROOT.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL CMUMPS_608(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & CMUMPS_608', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL CMUMPS_594(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL CMUMPS_683(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL CMUMPS_585(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE CMUMPS_584 SUBROUTINE CMUMPS_613(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*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_613' 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_613' 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_613 SUBROUTINE CMUMPS_614(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC), TARGET :: id CHARACTER*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_614' 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_614 SUBROUTINE CMUMPS_589(DEST,SRC,NB,NB_EFF) IMPLICIT NONE INTEGER NB, NB_EFF CHARACTER(LEN=NB) SRC CHARACTER*1 DEST(NB) INTEGER I DO I=1,NB_EFF DEST(I)=SRC(I:I) ENDDO END SUBROUTINE CMUMPS_589 SUBROUTINE CMUMPS_580(IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL CMUMPS_707(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE CMUMPS_580 SUBROUTINE CMUMPS_681(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_707(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE CMUMPS_681 SUBROUTINE CMUMPS_683(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_683 SUBROUTINE CMUMPS_688 & ( 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_695( 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_695( 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_688 SUBROUTINE CMUMPS_695( 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_690(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = CMUMPS_725 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = CMUMPS_725 & (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_695 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_695,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_695', & 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_695 ', & ' 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_697( 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_695 ', & ' 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_695" 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_695 SUBROUTINE CMUMPS_697( & 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_653( 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_697 INTEGER(8) FUNCTION CMUMPS_725 & (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_725 = TOTSIZE RETURN END FUNCTION CMUMPS_725 INTEGER FUNCTION CMUMPS_690( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER CMUMPS_748 CMUMPS_690=CMUMPS_748( & HBUF_SIZE, NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION CMUMPS_690 SUBROUTINE CMUMPS_728() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.CMUMPS_727())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_728 SUBROUTINE CMUMPS_809(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_809 END MODULE CMUMPS_OOC mumps-4.10.0.dfsg/src/mumps_io_err.c0000644000175300017530000001357511562233011017541 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #include "mumps_io_err.h" #include "mumps_io_basic.h" #if defined( MUMPS_WIN32 ) # include #endif /* Exported global variables */ char* mumps_err; MUMPS_INT* dim_mumps_err; int mumps_err_max_len; 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 = (int) *dim; err_flag = 0; return; } #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) MUMPS_INLINE int mumps_io_protect_err() { if(mumps_io_flag_async==IO_ASYNC_TH){ pthread_mutex_lock(&err_mutex); } return 0; } MUMPS_INLINE int mumps_io_unprotect_err() { if(mumps_io_flag_async==IO_ASYNC_TH){ pthread_mutex_unlock(&err_mutex); } return 0; } int mumps_io_init_err_lock() { pthread_mutex_init(&err_mutex,NULL); return 0; } int mumps_io_destroy_err_lock() { pthread_mutex_destroy(&err_mutex); return 0; } int mumps_check_error_th() { /* If err_flag != 0, then error_str is set */ return err_flag; } #endif /* MUMPS_WIN32 && WITHOUT_PTHREAD */ int mumps_io_error(int mumps_errno, const char* desc) { 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 = (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; } int mumps_io_sys_error(int mumps_errno, const char* desc) { int len = 2; /* length of ": " */ const char* _desc; char* _err; #if defined( MUMPS_WIN32 ) 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 += (int) strlen(desc); _desc = desc; } #if ! defined( MUMPS_WIN32 ) _err = strerror(errno); len += (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 = (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-4.10.0.dfsg/src/cmumps_struc_def.F0000644000175300017530000000430311562233067020346 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE CMUMPS_STRUC_DEF INCLUDE 'cmumps_struc.h' END MODULE CMUMPS_STRUC_DEF mumps-4.10.0.dfsg/src/dmumps_part2.F0000644000175300017530000074454611562233066017444 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE DMUMPS_152(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_729( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) ) IF (KEEP(216).eq.3) THEN SIZFR_BLOCK_EFF=SIZFR_BLOCK ELSE CALL DMUMPS_628( 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 ENDIF MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL DMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLU) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 IPOSSHIFT = IWPOSCB + KEEP(IXSZ) SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_729( 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) LRLUS = LRLUS + SIZFR_BLOCK_EFF CALL DMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLU) END IF RETURN END SUBROUTINE DMUMPS_152 SUBROUTINE DMUMPS_144( 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) USE DMUMPS_OOC 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), & PTRARW(LPTRAR), PTRAIW(LPTRAR), & ND( KEEP(28) ), FRERE( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) 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(max(1,KEEP(13))) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, & NBTLKJ, IBEG_BLOCK INTEGER(8) :: POSELT INTEGER NASS, NEL1, IEND, IOLDPS, dummy, allocok LOGICAL LASTBL DOUBLE PRECISION UUTEMP INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INCLUDE 'mumps_headers.h' EXTERNAL DMUMPS_224, DMUMPS_233, & DMUMPS_225, DMUMPS_232, & DMUMPS_294, & DMUMPS_44 LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC 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 IBEG_BLOCK=1 dummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5),NASS ) ENDIF NBTLKJ = NBOLKJ ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, & ' integers' IFLAG = -13 IERROR =NASS GO TO 490 END IF IF (KEEP(201).EQ.1) THEN CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_U 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 50 CONTINUE IBEGKJI = IBEG_BLOCK CALL DMUMPS_224(NFRONT,NASS,IBEGKJI, NASS, IPIV, & 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) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ENDIF IF (INOPV.GE.1) THEN LASTBL = (INOPV.EQ.1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL DMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, NFRONT, & IBEGKJI, IEND, IPIV, NASS,LASTBL, dummy, & & 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, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (INOPV.EQ.1) GO TO 500 IF (INOPV.EQ.2) THEN CALL DMUMPS_233(IBEG_BLOCK,NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP(IXSZ)) GOTO 50 ENDIF NPVW = NPVW + 1 IF (NASS.LE.1) THEN IFINB = -1 ELSE CALL DMUMPS_225(IBEG_BLOCK, & NFRONT, NASS, N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),KEEP(IXSZ)) ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 50 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN LASTBL = (IFINB.EQ.-1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL DMUMPS_294(COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, NFRONT, & IBEGKJI, IEND, IPIV, NASS, LASTBL, dummy, & & 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, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (IFINB.EQ.(-1)) GOTO 500 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV CALL DMUMPS_232(A,LA, & NFRONT,NPIV,NASS,POSELT,NBTLKJ) IF (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV TYPEFile = TYPEF_BOTH_LU LAST_CALL= .FALSE. CALL DMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG<0) RETURN ENDIF GO TO 50 490 CONTINUE CALL DMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE DEALLOCATE( IPIV ) IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) TYPEFile = TYPEF_BOTH_LU LAST_CALL = .TRUE. CALL DMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG<0) RETURN CALL DMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE DMUMPS_144 SUBROUTINE DMUMPS_176( 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, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE DMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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(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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) 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 INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_73(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'DMUMPS_73' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL DMUMPS_270( 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, 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_275(PROCNODE_STEPS(STEP(IN)),SLAVEF) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL DMUMPS_74(IN, NELIM_SENT, & PDEST, COMM, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'DMUMPS_73' CALL MUMPS_ABORT() endif ELSE CALL DMUMPS_271( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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 CALL DMUMPS_626( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL DMUMPS_152( .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_176 SUBROUTINE DMUMPS_268(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, NBPROCFILS, & IPOOL, LPOOL, LEAF, KEEP,KEEP8, 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) 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 NBPROCFILS( 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_330 EXTERNAL MUMPS_330 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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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 + 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 ( ( KEEP(48).NE. 0 ).AND.(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_330(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_507(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE DMUMPS_268 SUBROUTINE DMUMPS_242(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF) USE DMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST 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_62( DATA(1), DEST, TAG, & COMMW, IERR ) ELSE WRITE(*,*) 'Error : bad argument to DMUMPS_242' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE DMUMPS_242 SUBROUTINE DMUMPS_44( MYID, SLAVEF, COMM ) INTEGER MYID, SLAVEF, COMM INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) CALL DMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF ) RETURN END SUBROUTINE DMUMPS_44 SUBROUTINE DMUMPS_464( K34, K35, K16, K10 ) IMPLICIT NONE INTEGER, INTENT(OUT) :: K34, K35, K10, K16 INTEGER SIZE_INT, SIZE_REAL_OR_DOUBLE INTEGER I(2) DOUBLE PRECISION R(2) 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_464 SUBROUTINE DMUMPS_20( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP) IMPLICIT NONE DOUBLE PRECISION DKEEP(30) DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(40), KEEP(500), SYM, PAR, NSLAVES INTEGER INFO(40), INFOG(40) INTEGER(8) KEEP8(150) INTEGER LWK_USER C Let $A_{preproc}$ be the preprocessed matrix to be factored (see 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:30) = 0.0D0 KEEP( 50 ) = SYM IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 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 KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN KEEP(46) = 1 END IF ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 ICNTL(5) = 0 IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF ICNTL(7) = 7 ICNTL(8) = 77 ICNTL(9) = 1 ICNTL(10) = 0 ICNTL(11) = 0 IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF ICNTL(13) = 0 IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ELSE IF (NSLAVES .GT. 4) THEN ICNTL(14) = 30 ELSE ICNTL(14) = 20 END IF ICNTL(15) = 0 ICNTL(16) = 0 ICNTL(17) = 0 ICNTL(18) = 0 ICNTL(19) = 0 ICNTL(20) = 0 ICNTL(21) = 0 ICNTL(22) = 0 ICNTL(23) = 0 ICNTL(24) = 0 ICNTL(27) = -8 ICNTL(28) = 1 ICNTL(29) = 0 ICNTL(39) = 1 ICNTL(40) = 0 KEEP(12) = 0 KEEP(11) = 2147483646 KEEP(24) = 18 KEEP(68) = 0 KEEP(36) = 1 KEEP(1) = 8 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 IF (NSLAVES.GE.128) KEEP(62)=200 IF (NSLAVES.GE.128) KEEP(9)=800 IF (NSLAVES.GE.256) KEEP(9)=900 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 48 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 100 IF (NSLAVES.GE.128) KEEP(62)=150 IF (NSLAVES.GE.64) KEEP(9)=800 IF (NSLAVES.GE.128) KEEP(9)=900 END IF KEEP(63) = 60 KEEP(48) = 5 KEEP(17) = 0 CALL DMUMPS_464( KEEP(34), KEEP(35), & KEEP(16), KEEP(10) ) #if defined(SP_) KEEP( 51 ) = 70 #else KEEP( 51 ) = 48 #endif 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) = 10 KEEP(69) = 4 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 30 KEEP(79) = 0 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) = 5 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 #else KEEP(99)=4 #endif KEEP(100)=0 KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 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 IF(NSLAVES.LE.8)THEN KEEP(238)=12 ELSE KEEP(238)=7 ENDIF KEEP(234)= 1 DKEEP(3)=-5.0D0 KEEP(242) = 1 KEEP(250) = 1 RETURN END SUBROUTINE DMUMPS_20 SUBROUTINE DMUMPS_786(id, LP) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN IF (LP.GT.0) & write(LP,*) 'Warning KEEP(72) = 1 !!!!!!!!!! ' 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 ELSE IF (id%KEEP(72)==2) THEN IF (LP.GT.0) & write(LP,*)' OOC setting to reduce stack memory', & ' KEEP(72)=', id%KEEP(72) id%KEEP(85)=2 id%KEEP(85)=-10000 id%KEEP(62) = 10 id%KEEP(210) = 1 id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 id%KEEP(102) = 110 id%KEEP(213) = 121 END IF RETURN END SUBROUTINE DMUMPS_786 SUBROUTINE DMUMPS_195(N, NZ, IRN, ICN, LIW, IKEEP, PTRAR, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N,NZ,LIW,IORD,SIZE_SCHUR, NSLAVES INTEGER PTRAR(N,4), NFSIZ(N), FILS(N), FRERE(N) INTEGER IKEEP(N,3) INTEGER LISTVAR_SCHUR(SIZE_SCHUR) INTEGER INFO(40), ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) TYPE (DMUMPS_STRUC) :: id INTEGER IRN(NZ), ICN(NZ) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER IERR INTEGER K,I,L1,L2,IWFR,NCMPA,LLIW, IN, IFSON INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER MedDens, NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: HEAD INTEGER NUMFLAG INTEGER OPT_METIS_SIZE INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS 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 EXTERNAL MUMPS_197, DMUMPS_198, & DMUMPS_199, DMUMPS_351, & DMUMPS_557, DMUMPS_201 #if defined(OLDDFS) EXTERNAL DMUMPS_200 #endif EXTERNAL DMUMPS_623 EXTERNAL DMUMPS_547, DMUMPS_550, & DMUMPS_556 ALLOCATE( IW ( LIW ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW RETURN ENDIF LLIW = LIW - 2*N - 1 L1 = LLIW + 1 L2 = L1 + N LP = ICNTL(1) MP = ICNTL(3) PROK = (MP.GT.0) 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, NZ, LIW, INFO(1) K = min0(10,NZ) IF (LDIAG.EQ.4) K = NZ IF (K.GT.0) WRITE (MP,99998) (IRN(I),ICN(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 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) 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 CALL DMUMPS_623(N,NCMP,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), MedDens, NBQD, AvgDens, & LISTVAR_SCHUR, SIZE_SCHUR, & FRERE,FILS) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif CALL DMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), MedDens, NBQD, AvgDens) #if defined(metis) || defined(parmetis) 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 DMUMPS_701( N, KEEP(50), NSLAVES, IORD, & symmetry, MedDens, 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_195 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_195 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_556( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8,id) ENDIF IF ( IORD .NE. 1 ) THEN IF(COMPRESS .GE. 1) THEN CALL DMUMPS_547( & N,NZ, IRN, ICN, PIV, & NCMP, IW(1), LLIW, IW(L2),PTRAR(1,2),PTRAR, & IW(L1), FILS, IWFR, & IERROR, KEEP,KEEP8, ICNTL) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 DEALLOCATE (IW) RETURN 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 K=1,NZ J = ICN(K) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(K) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N RETURN 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 (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' CALL DMUMPS_351 & (N,NZ,IRN, ICN, IW(1), LLIW, IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & MedDens, NBQD, AvgDens) 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 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 ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_162(N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & 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 IF(COMPRESS .EQ. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO CALL MUMPS_PORDF_WND(NCMP, IWFR-1, IW(L2), IW, & IW(L1), NCMPA, N) CALL DMUMPS_548(NCMP,IW(L2),IW(L1),FILS) CALL DMUMPS_549(NCMP,IW(L2),IKEEP(1,1), & FRERE,PTRAR(1,1)) DO I=1,NCMP IKEEP(IKEEP(I,1),2)=I ENDDO ELSE CALL MUMPS_PORDF(NCMP, IWFR-1, IW(L2), IW(1), & IW(L1), NCMPA) ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 RETURN ENDIF #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH(NCMP, LLIW, IW(L2), IWFR, & PTRAR(1,2), IW(1), IW(L1), IKEEP, & IKEEP(1,2), NCMPA) IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out SCTOCH, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 3 RETURN ENDIF IF (COMPRESS .EQ. 1) THEN CALL DMUMPS_548(NCMP,IW(L2),IW(L1),FILS) CALL DMUMPS_549(NCMP,IW(L2),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( HEAD ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 RETURN ENDIF IF(COMPRESS .GE. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO ELSE IW(L1) = -1 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_337(NCMP, NBBUCK, LLIW, IW(L2), & IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_560(NCMP, NBBUCK, LLIW, IW(L2), & IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD, & NFSIZ, FRERE) ENDIF DEALLOCATE(HEAD) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( HEAD ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N RETURN ENDIF THRESH = 1 IVersion = 2 IF(COMPRESS .EQ. 1) THEN DO I=L1,L1-1+KEEP(93)/2 IW(I) = 2 ENDDO DO I=L1+KEEP(93)/2,L1+NCMP-1 IW(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IW(L1) = -1 TOTEL = N ENDIF CALL MUMPS_421(TOTEL,IVersion, THRESH, HEAD, & NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), & IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3)) DEALLOCATE(HEAD) ELSE CALL MUMPS_197(NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, & IKEEP(1,3), PTRAR, PTRAR(1,3)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL DMUMPS_550(N,NCMP,KEEP(94),KEEP(93), & PIV,IKEEP(1,1),IKEEP(1,2)) COMPRESS = -1 ENDIF ENDIF #if defined(metis) || defined(parmetis) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS ' ENDIF 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 RETURN ENDIF OPTIONS_METIS(1) = 0 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FILS(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FILS(I) = 1 ENDDO CALL METIS_NODEWND(NCMP, IW(L2), IW(1),FILS, & NUMFLAG, OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) ELSE CALL METIS_NODEND(NCMP, IW(L2), IW(1), NUMFLAG, & OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) ENDIF DEALLOCATE (OPTIONS_METIS) IF ( COMPRESS_SCHUR ) THEN CALL DMUMPS_622( & N, NCMP, IKEEP(1,1),IKEEP(1,2), & LISTVAR_SCHUR, SIZE_SCHUR, FILS) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL DMUMPS_550(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) THEN IF ( COMPRESS .EQ. -1 ) THEN CALL DMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, & IW(L2), PTRAR(1,2), & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & MedDens, NBQD, AvgDens) INFO(8) = symmetry ENDIF COMPRESS = 0 ALLOCATE( HEAD ( 2*N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 2*N RETURN 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 =.TRUE. CALL MUMPS_422(THRESH, HEAD, & N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW, & IW(L1), HEAD(N+1), & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), & IKEEP(1,1), LISTVAR_SCHUR, ITEMP, AGG6) DEALLOCATE(HEAD) ELSE CALL DMUMPS_198(N, NZ, IRN, ICN, IKEEP, IW(1), & LLIW, IW(L2), & PTRAR(1,2), IW(L1), IWFR, & INFO(1),INFO(2), KEEP(11), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 CALL DMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & PTRAR, NCMPA, ITEMP) ELSE CALL DMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & PTRAR, NCMPA, SIZE_SCHUR) 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_200 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else CALL DMUMPS_557 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), & NFSIZ, PTRAR, INFO(6), FILS, FRERE, & PTRAR(1,3), NEMIN, PTRAR(1,4), KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1) #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_201(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_209( 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_510(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 IF ( huge(KEEP8(79)) / K79REF + 1_8 .GE. int(NSLAVES,8) ) THEN KEEP8(79)=huge(KEEP8(79)) ELSE KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF 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_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG,INFO(1),INFO(2)) IF (INFO(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) & .AND. (KEEP(60).EQ.0) IF (SPLITROOT) THEN CALL DMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG,INFO(1),INFO(2)) IF (INFO(1).LT.0) RETURN 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,99986) (PTRAR(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99985) (PTRAR(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99984) (PTRAR(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 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) GOTO 90 90 CONTINUE DEALLOCATE(IW) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NZ 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)=', 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)) 99986 FORMAT ('PTRAR(.,1)=', 10I6/(12X, 10I6)) 99985 FORMAT ('PTRAR(.,2)=', 10I6/(12X, 10I6)) 99984 FORMAT ('PTRAR(.,3)=', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE DMUMPS_195 SUBROUTINE DMUMPS_199(N,IPE,IW, LW, IWFR, IPS, IPV, NV, FLAG, & NCMPA, SIZE_SCHUR) INTEGER N,LW,IWFR,NCMPA,SIZE_SCHUR INTEGER FLAG(N) INTEGER IPS(N), IPV(N) INTEGER IW(LW), NV(N), IPE(N) INTEGER I,J,ML,MS,ME,IP,MINJS,IE,KDUMMY,JP INTEGER LN,JP1,JS,LWFR,JP2,JE 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) GO TO 60 LN = IW(JP) DO 50 JP1=1,LN JP = JP + 1 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 - JP1 CALL DMUMPS_194(N, IPE, IW, IP-1, 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 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min0(MINJS,IPS(JS)+0) IWFR = IWFR + 1 50 CONTINUE 60 IPE(IE) = -ME 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 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = IWFR - IP IPE(ME) = IP IWFR = IWFR + 1 100 CONTINUE IF (SIZE_SCHUR == 0) RETURN 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) GO TO 160 LN = IW(JP) 160 IPE(IE) = -IPV(N-SIZE_SCHUR+1) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = -IPV(N-SIZE_SCHUR+1) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0 NV(ME) = SIZE_SCHUR RETURN END SUBROUTINE DMUMPS_199 SUBROUTINE DMUMPS_198(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, IOVFLO, MP) INTEGER N,NZ,LW,IWFR,IFLAG,IERROR INTEGER PERM(N) INTEGER IQ(N) INTEGER IRN(NZ), ICN(NZ) INTEGER IPE(N), IW(LW), FLAG(N) INTEGER MP INTEGER IOVFLO INTEGER I,J,K,LBIG,L,ID,IN,LEN,JDUMMY,K1,K2 IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1,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 LBIG = 0 DO 100 I=1,N L = IQ(I) LBIG = max0(L,LBIG) IWFR = IWFR + L IPE(I) = IWFR - 1 100 CONTINUE DO 140 K=1,NZ I = -IW(K) IF (I.LE.0) GO TO 140 L = K IW(K) = 0 DO 130 ID=1,NZ J = ICN(L) IF (PERM(I).LT.PERM(J)) GO TO 110 L = IPE(J) IPE(J) = L - 1 IN = IW(L) IW(L) = I GO TO 120 110 L = IPE(I) IPE(I) = L - 1 IN = IW(L) IW(L) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1 L = K + N IWFR = L + 1 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(L) = IW(K) K = K - 1 L = L - 1 150 CONTINUE 160 IPE(J) = L L = L - 1 170 CONTINUE IF (LBIG.GE.IOVFLO) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0 180 CONTINUE GO TO 230 190 IWFR = 1 DO 220 I=1,N K1 = IPE(I) + 1 K2 = IPE(I) + IQ(I) IF (K1.LE.K2) GO TO 200 IPE(I) = 0 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = IWFR - K - 1 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM DMUMPS_198 ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE DMUMPS_198 SUBROUTINE DMUMPS_194(N, IPE, IW, LW, IWFR,NCMPA) INTEGER N,LW,IWFR,NCMPA INTEGER IPE(N) INTEGER IW(LW) INTEGER I,K1,LWFR,IR,K,K2 NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0) GO TO 10 IPE(I) = IW(K1) IW(K1) = -I 10 CONTINUE IWFR = 1 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) = IPE(I) IPE(I) = IWFR K1 = K + 1 K2 = K + IW(IWFR) IWFR = IWFR + 1 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1 40 CONTINUE 50 LWFR = K2 + 1 60 CONTINUE 70 RETURN END SUBROUTINE DMUMPS_194 #if defined(OLDDFS) SUBROUTINE DMUMPS_200(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_200 #else SUBROUTINE DMUMPS_557(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 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 #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 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 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 #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(20000)* & dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) & ) & / & ( dble(NV(DADI)+NODE(I))* & dble(NV(DADI)+NODE(I)) ) ACCU = ACCU + dble(CUMUL(I) ) AMALG_TO_father_OK = ( (NODE(I).LE.NEMIN).OR. & (NODE(DADI).LE.NEMIN) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( & ( dble(2*(NODE(I)))* & dble((NV(DADI)-NV(I)+NODE(I))) & ) .LT. & ( dble(NV(DADI)+NODE(I))* & dble(NV(DADI)+NODE(I))*dble(NEMIN)/dble(100) & ) & ) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU .LE. dble(NEMIN)*dble(100) ) & ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_511(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_511(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_511(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF(FLOPS_APRES .GT. FLOPS_AVANT) 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 AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) 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_557 #endif SUBROUTINE DMUMPS_201(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 IF(NFR .NE. NELIM) 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_201 SUBROUTINE DMUMPS_348( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(INOUT) :: 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_348 SUBROUTINE DMUMPS_203( N, NZ, MTRANS, PERM, & id, ICNTL, INFO) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER N, NZ, LIWG INTEGER PERM(N) INTEGER MTRANS INTEGER ICNTL(40), INFO(40) INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER LS2,LSC INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) DOUBLE PRECISION CNTL64(10) INTEGER LDW, LDWMIN INTEGER MPRINT,LP, MP, IPIW, LIW, LIWMIN INTEGER JPERM INTEGER NUMNZ, I, J, JPOS, K, NZREAL INTEGER PLENR, IP, IRNW,RSPOS,CSPOS LOGICAL PROK, IDENT, DUPPLI INTEGER NZTOT, K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG 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) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = (MPRINT.GT.0) 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 .EQ. 2) THEN NZTOT = 2*NZ+N ELSE NZTOT = NZ ENDIF ZERODIAG => id%IS1(N+1:2*N) STR_KER => id%IS1(2*N+1:3*N) CALL DMUMPS_448(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 DIAGIONAL' 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 IP = IRNW + NZTOT PLENR = IP + N + 1 IPIW = PLENR IF (MTRANSLOC.EQ.1) LIWMIN = 5*N IF (MTRANSLOC.EQ.2) LIWMIN = 4*N IF (MTRANSLOC.EQ.3) LIWMIN = 10*N + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 5*N IF (MTRANSLOC.EQ.5) LIWMIN = 5*N IF (MTRANSLOC.EQ.6) LIWMIN = 5*N + NZTOT LIW = LIWMIN LIWG = LIW + (NZTOT + N + 1) ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) GOTO 410 IF (MTRANSLOC.EQ.1) THEN LDWMIN = N+3 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max(N+NZTOT,N+3) IF (MTRANSLOC.EQ.3) LDWMIN = max(NZTOT+1,N+3) IF (MTRANSLOC.EQ.4) LDWMIN = 2*N + max(NZTOT,N+3) IF (MTRANSLOC.EQ.5) LDWMIN = 3*N + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4*N + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N IF (allocok .GT. 0 ) GOTO 430 NZREAL = 0 DO 5 J=1,N IW(PLENR+J-1) = 0 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 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 NZREAL = NZREAL + 1 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 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 NZREAL = NZREAL + 1 IF(I .NE. J) THEN IW(PLENR+I-1) = IW(PLENR+I-1) + 1 NZREAL = NZREAL + 1 ELSE IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = K 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 IW(PLENR+I-1) = IW(PLENR+I-1) + 1 NZREAL = NZREAL + 1 ENDIF ENDDO ENDIF ENDIF IW(IP) = 1 DO 20 J=1,N IW(IP+J) = IW(IP+J-1)+IW(PLENR+J-1) 20 CONTINUE DO 25 J=1, N IW(PLENR+J-1 ) = IW(IP+J-1 ) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO 30 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I IW(PLENR+J-1) = IW(PLENR+J-1) + 1 ENDIF 30 CONTINUE ELSE IF ( .not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO 35 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I S2(JPOS) = abs(id%A(K)) IW(PLENR+J-1) = IW(PLENR+J-1) + 1 ENDIF 35 CONTINUE 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I IW(PLENR+J-1) = IW(PLENR+J-1) + 1 IF(I.NE.J) THEN JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = J IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(id%A)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF K = 1 THEMIN = ZERO DO IF(THEMIN .NE. ZERO) EXIT THEMIN = abs(id%A(K)) K = K+1 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 JPOS = IW(PLENR+J-1) IW(IRNW+JPOS-1) = I S2(JPOS) = abs(id%A(K)) IW(PLENR+J-1) = IW(PLENR+J-1) + 1 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 JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = J S2(JPOS) = abs(id%A(K)) IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN JPOS = IW(PLENR+I-1) IW(IRNW+JPOS-1) = I S2(JPOS) = ZERO IW(PLENR+I-1) = IW(PLENR+I-1) + 1 ENDIF ENDDO CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N)) & - log(THEMIN) + ONE ENDIF ENDIF DUPPLI = .FALSE. I = NZREAL FLAG => id%IS1(3*N+1:4*N) IF(MTRANSLOC.NE.1) THEN CALL DMUMPS_563(N,NZREAL,IW(IP),IW(IRNW),S2, & PERM,FLAG(1)) ELSE CALL DMUMPS_562(N,NZREAL,IW(IP),IW(IRNW), & PERM,FLAG(1)) ENDIF IF(NZREAL .NE. I) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1 LDW = 1 ENDIF CALL DMUMPS_559(MTRANSLOC ,N, N, NZREAL, & IW(IP), IW(IRNW), S2(1), LS2, & NUMNZ, PERM, LIW, IW(IPIW), LDW, S2(LS2+1), & ICNTL64, CNTL64, INFO64) 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(PLENR+JPERM-1) = 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(PLENR+J-1) 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_203' 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_203' 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 id%ROWSCA(J) = exp(S2(RSPOS+J)) 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+J)) IF(id%COLSCA(J) .EQ. ZERO) THEN id%COLSCA(J) = ONE ENDIF ELSE id%COLSCA(IW(PLENR+J-1))= exp(S2(CSPOS+J)) IF(id%COLSCA(IW(PLENR+J-1)) .EQ. ZERO) THEN id%COLSCA(IW(PLENR+J-1)) = 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_203' 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_203' 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)+S2(CSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO S2(CSPOS+J)= ZERO ENDIF ENDDO DO J=1,N IF(PERM(J) .GT. 0) THEN id%ROWSCA(J) = & exp((S2(RSPOS+J)+S2(CSPOS+J))/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 J = IW(IP+I-1),IW(IP+I) - 1 IF ( PERM( IW( IRNW+J-1) ) > 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_551( & N, NZREAL, IW(IP), 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_203' 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_203' WRITE (LP,'(A,I9)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -5 INFO(2) = LIWG GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_203' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 INFO(2) = LDW 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) RETURN END SUBROUTINE DMUMPS_203 SUBROUTINE DMUMPS_100 &( 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) 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_100 SUBROUTINE DMUMPS_97 & ( 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) MAX_DEPTH=1 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) 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_313 & ( 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_97 RECURSIVE SUBROUTINE DMUMPS_313 & ( 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_50, & MUMPS_52 EXTERNAL MUMPS_50, & MUMPS_52 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_50 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB) NSLAVESMAX = MUMPS_52 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB) 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 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 ) CALL DMUMPS_313 & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG ) IF (.NOT. SPLITROOT) THEN CALL DMUMPS_313 & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG ) ENDIF RETURN END SUBROUTINE DMUMPS_313 SUBROUTINE DMUMPS_351 & (N,NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, MedDens, NBQD, AvgDens) INTEGER N,NZ,LW,IFLAG,IERROR,NRORM,NIORM,IWFR INTEGER symmetry, SYM INTEGER MedDens, NBQD, AvgDens INTEGER ICNTL(40) INTEGER IRN(NZ), ICN(NZ) INTEGER LEN(N) INTEGER IPE(N+1) INTEGER FLAG(N), IW(LW) INTEGER IQ(N) INTEGER MP, MPG INTEGER I,K,J,N1,LAST,NDUP,K1,K2,L INTEGER NBERR, THRESH INTEGER NZOFFA, NDIAGA DOUBLE PRECISION RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NIORM = 3*N NDIAGA = 0 IERROR = 0 DO 10 I=1,N IPE(I) = 0 10 CONTINUE DO 50 K=1,NZ I = IRN(K) J = ICN(K) 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 IPE(J) = IPE(J) + 1 NIORM = NIORM + 1 ELSE NDIAGA = NDIAGA + 1 ENDIF ENDIF 50 CONTINUE NZOFFA = NIORM - 3*N 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 K=1,NZ I = IRN(K) J = ICN(K) 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(K,10).GT.3 .OR. mod(K,10).EQ.0 .OR. & (10.LE.K .AND. K.LE.20)) THEN WRITE (MP,'(I8,A,I8,A,I8,A)') & K,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K,10).EQ.1) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'st entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.2) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.3) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2*N IQ(1) = 1 N1 = N - 1 IF (N1.GT.0) THEN DO 110 I=1,N1 IQ(I+1) = IPE(I) + IQ(I) 110 CONTINUE 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 DO 200 K=1,NZ I = IRN(K) J = ICN(K) 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 200 CONTINUE NDUP = 0 DO 260 I=1,N K1 = IPE(I) K2 = IQ(I) -1 IF (K1.GT.K2) THEN LEN(I) = 0 IQ(I) = 0 ELSE DO 240 K=K1,K2 J = -IW(K) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1 IW(L) = 0 IW(K) = 0 ELSE IW(L) = I IW(K) = J FLAG(J) = I ENDIF 240 CONTINUE 250 IQ(I) = IQ(I) - IPE(I) IF (NDUP.EQ.0) LEN(I) = IQ(I) ENDIF 260 CONTINUE IF (NDUP.NE.0) THEN IWFR = 1 DO 280 I=1,N IF (IQ(I).EQ.0) THEN LEN(I) = 0 IPE(I) = IWFR GOTO 280 ENDIF K1 = IPE(I) K2 = K1 + IQ(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K=K1,K2 IF (IW(K).NE.0) THEN IW(IWFR) = IW(K) IWFR = IWFR + 1 ENDIF 270 CONTINUE LEN(I) = IWFR - L 280 CONTINUE ENDIF IPE(N+1) = IPE(N) + LEN(N) IWFR = IPE(N+1) IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2*NZOFFA - (IWFR-1))/ & dble(NZOFFA+NDIAGA) symmetry = nint (100.0D0*RSYM) IF (MPG .GT. 0) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ELSE symmetry = 100 ENDIF AvgDens = nint(dble(IWFR-1)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN IQ(1:N) = 0 DO I= 1, N K = max(LEN(I),1) IQ(K) = IQ(K) + 1 IF (K.GT.THRESH) NBQD = NBQD+1 ENDDO K = 0 MedDens = 0 DO WHILE (K .LT. (N/2)) MedDens = MedDens + 1 K = K+IQ(MedDens) ENDDO ELSE MedDens = AvgDens ENDIF IF (MPG .GT. 0) & write(MPG,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE DMUMPS_351 SUBROUTINE DMUMPS_701(N, SYM, NPROCS, IORD, & symmetry,MedDens, NBQD, AvgDens, & PROK, MP) IMPLICIT NONE INTEGER, intent(in) :: N, NPROCS, SYM INTEGER, intent(in) :: symmetry,MedDens, 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) 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 (NBQD.GE.MedDens*NPROCS) THEN IORD = 6 RETURN ENDIF #if defined(metis) || defined(parmetis) 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 (NBQD.GE.MedDens*NPROCS) THEN IORD = 6 RETURN ENDIF #if defined(metis) || defined(parmetis) 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 DMUMPS_701 SUBROUTINE DMUMPS_510 & (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_510 SUBROUTINE DMUMPS_559(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & ICNTL,CNTL,INFO) IMPLICIT NONE INTEGER NICNTL, NCNTL, NINFO PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER JOB,M,N,NE,NUM,LIW,LDW INTEGER IP(N+1),IRN(NE),PERM(M),IW(LIW) INTEGER ICNTL(NICNTL),INFO(NINFO) INTEGER LA DOUBLE PRECISION A(LA) DOUBLE PRECISION DW(LDW),CNTL(NCNTL) INTEGER I,J,K,WARN1,WARN2,WARN4 DOUBLE PRECISION FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0D+00,ONE=1.0D+0) EXTERNAL DMUMPS_457,DMUMPS_444,DMUMPS_451, & DMUMPS_452,DMUMPS_454 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 INFO(2) = NE IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = 4*N + M IF (JOB.EQ.2) K = 2*N + 2*M IF (JOB.EQ.3) K = 8*N + 2*M + NE IF (JOB.EQ.4) K = 3*N + 2*M IF (JOB.EQ.5) K = 3*N + 2*M IF (JOB.EQ.6) K = 3*N + 2*M + NE IF (LIW.LT.K) THEN INFO(1) = -4 INFO(2) = K 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 = M IF (JOB.EQ.3) K = 1 IF (JOB.EQ.4) K = 2*M IF (JOB.EQ.5) K = N + 2*M IF (JOB.EQ.6) K = N + 3*M IF (LDW.LT.K) THEN INFO(1) = -5 INFO(2) = K 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 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(J),J=1,min(10,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,min(10,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(J),J=1,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,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) = IP(J+1) - IP(J) 10 CONTINUE CALL DMUMPS_457(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_444(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(2*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_451(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL DMUMPS_452(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) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1 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 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IW(1) = JOB CALL DMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) 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 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 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 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 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_451(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 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 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IW(1) = JOB IF (JOB.EQ.5) THEN CALL DMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL DMUMPS_454(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM, & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), & DW(1),DW(M+1),RINF2) 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 (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_443. INFO(1) = ',I2, & ' because ',(A),' = ',I10) 9004 FORMAT (' ****** Error in DMUMPS_443. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I8) 9005 FORMAT (' ****** Error in DMUMPS_443. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I8) 9006 FORMAT (' ****** Error in DMUMPS_443. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in DMUMPS_443. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from DMUMPS_443. 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_443:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I10) 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_443:'/ & ' 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_559 SUBROUTINE DMUMPS_563(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER N,NZ INTEGER IP(N+1),IRN(NZ) DOUBLE PRECISION A(NZ) INTEGER WR_POS,BEG_COL,ROW,COL,K,SV_POS INTEGER FLAG(N), POSI(N) FLAG = 0 WR_POS = 1 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1 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 RETURN END SUBROUTINE DMUMPS_563 SUBROUTINE DMUMPS_562(N,NZ,IP,IRN,FLAG,POSI) IMPLICIT NONE INTEGER N,NZ INTEGER IP(N+1),IRN(NZ) INTEGER WR_POS,BEG_COL,ROW,COL,K INTEGER FLAG(N), POSI(N) FLAG = 0 WR_POS = 1 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1 RETURN END SUBROUTINE DMUMPS_562 SUBROUTINE DMUMPS_181( 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_181 SUBROUTINE DMUMPS_746( ID, PTRAR ) USE DMUMPS_STRUC_DEF IMPLICIT NONE include 'mpif.h' TYPE(DMUMPS_STRUC), INTENT(IN), TARGET :: ID INTEGER, TARGET :: PTRAR(ID%N,2) INTEGER :: IERR INTEGER :: IOLD, K, JOLD, INEW, JNEW, INZ INTEGER, POINTER :: IIRN(:), IJCN(:), IWORK1(:), IWORK2(:) LOGICAL :: IDO, PARANAL PARANAL = .TRUE. IF (PARANAL) THEN IF(ID%KEEP(54) .EQ. 3) THEN IIRN => ID%IRN_loc IJCN => ID%JCN_loc INZ = ID%NZ_loc IWORK1 => PTRAR(1:ID%N,2) allocate(IWORK2(ID%N)) IDO = .TRUE. ELSE IIRN => ID%IRN IJCN => ID%JCN INZ = ID%NZ IWORK1 => PTRAR(1:ID%N,1) IWORK2 => PTRAR(1:ID%N,2) IDO = ID%MYID .EQ. 0 END IF ELSE IIRN => ID%IRN IJCN => ID%JCN INZ = ID%NZ 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 IWORK2(IOLD) = 0 50 CONTINUE IF(IDO) THEN DO 70 K=1,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 ELSE IWORK1(JOLD) = IWORK1(JOLD) + 1 ENDIF ELSE IF ( INEW .LT. JNEW ) THEN IWORK1( IOLD ) = IWORK1( IOLD ) + 1 ELSE IWORK1( JOLD ) = IWORK1( JOLD ) + 1 END IF ENDIF ENDIF 70 CONTINUE END IF IF(PARANAL .AND. (ID%KEEP(54) .EQ. 3) ) THEN CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1,1), ID%N, MPI_INTEGER, & MPI_SUM, ID%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), ID%N, MPI_INTEGER, & MPI_SUM, ID%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR, 2*ID%N, MPI_INTEGER, & 0, ID%COMM, IERR ) END IF RETURN END SUBROUTINE DMUMPS_746 MODULE DMUMPS_PARALLEL_ANALYSIS USE DMUMPS_STRUC_DEF USE TOOLS_COMMON INCLUDE 'mpif.h' PUBLIC DMUMPS_715 INTERFACE DMUMPS_715 MODULE PROCEDURE DMUMPS_715 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 :: NZ_LOC, 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 :: MEMCNT, MAXMEM, MP, MPG, LP, NRL, TOPROWS LOGICAL :: PROK, PROKG CONTAINS SUBROUTINE DMUMPS_715(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) 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%NZ_loc = id%NZ ELSE id%NZ_loc = 0 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) MEMCNT = size(work1)+ size(work2) + & size(nfsiz) + size(fils) + size(frere) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT entry:',MEMCNT,MAXMEM #endif CALL DMUMPS_716(id, ord) id%INFOG(7) = id%KEEP(245) CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL DMUMPS_717(id, ord, WORK2) CALL MUMPS_276( 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_733(IPE, id%N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NV, id%N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT ipe nv:',MEMCNT,MAXMEM #endif END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 CALL DMUMPS_720(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_276( 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_734(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT firstlast:',MEMCNT,MAXMEM #endif 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_733(CUMUL, id%N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT cumul:',MEMCNT,MAXMEM #endif NEMIN = id%KEEP(1) CALL DMUMPS_557(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_734(CUMUL, NV, IPE, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall cumul:',MEMCNT,MAXMEM #endif CALL DMUMPS_201(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_209(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_510(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 IF ( huge(id%KEEP8(79)) / K79REF + 1_8 .GE. & int(id%NSLAVES,8) ) THEN id%KEEP8(79)=huge(id%KEEP8(79)) ELSE id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF 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_97(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_97(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 #if defined (memprof) write(mp,'(i2,a30,3(i8,5x))')myid,'MEMCNT exit:',MEMCNT,MAXMEM, & estimem(myid, id%n, 2*id%nz/id%n) #endif RETURN END SUBROUTINE DMUMPS_715 SUBROUTINE DMUMPS_716(id, ord) TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: IERR #if defined(parmetis) 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) IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to PT-SCOTCH.")') RETURN #endif #if defined(parmetis) I=1 DO IF (I .GT. id%NSLAVES) 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.")') 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) I=1 DO IF (I .GT. id%NSLAVES) 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_716 SUBROUTINE DMUMPS_717(id, ord, WORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) #ifdef parmetis INTEGER :: IERR #endif IF (ord%ORDTOOL .EQ. 1) THEN #ifdef ptscotch CALL DMUMPS_719(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 #ifdef parmetis CALL DMUMPS_718(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_717 #if defined(parmetis) SUBROUTINE DMUMPS_718(id, ord, WORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR, BASE INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & EDGELOCNBR, OPTIONS(10), NROWS_LOC INTEGER, POINTER :: VERTLOCTAB(:), & EDGELOCTAB(:), RCVCNTS(:) 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) IF(MUMPS_795(WORK) .LT. ID%N*3) THEN WRITE(LP, & '("Insufficient workspace inside DMUMPS_718")') CALL MUMPS_ABORT() END IF CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, LP, & STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, LP, & STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT perm peri:', & MEMCNT,MAXMEM #endif BASEVAL = 1 BASE = id%NPROCS-id%NSLAVES VERTLOCTAB => ord%PERMTAB CALL MUMPS_733(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, & MAXMEM #endif DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO DO I=BASE, BASE+ord%NSLAVES-2 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) END DO FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* & (BASE+ord%NSLAVES-1-BASE)+1 LAST(BASE+ord%NSLAVES) = id%N DO I=BASE+ord%NSLAVES, NPROCS FIRST(I+1) = id%N+1 LAST(I+1) = id%N END DO VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 SWORK => WORK(id%N+1:3*id%N) CALL DMUMPS_776(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 OPTIONS(:) = 0 NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 ORDER => WORK(1:id%N) CALL MUMPS_733(SIZES, 2*ord%NSLAVES, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT sizes:',MEMCNT,MAXMEM #endif IF(ord%IDO) THEN CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB, & EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES) END IF CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM #endif NULLIFY(VERTLOCTAB) CALL MPI_BCAST(SIZES, 2*ord%NSLAVES, MPI_INTEGER, & BASE, id%COMM, IERR) ord%CBLKNBR = 2*ord%NSLAVES-1 CALL MUMPS_733(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rcvcnts:',MEMCNT,MAXMEM #endif 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, NROWS_LOC, MPI_INTEGER, ord%PERMTAB, & RCVCNTS, FIRST, MPI_INTEGER, id%COMM, IERR ) DO I=1, id%N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_733(ord%RANGTAB, 2*ord%NSLAVES, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rangtab:',MEMCNT,MAXMEM #endif CALL MUMPS_733(ord%TREETAB, ord%CBLKNBR, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_778(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_734(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sizes:',MEMCNT,MAXMEM #endif CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM #endif CALL DMUMPS_777(ord) ord%N = id%N ord%COMM = id%COMM RETURN END SUBROUTINE DMUMPS_718 #endif #if defined(ptscotch) SUBROUTINE DMUMPS_719(id, ord, WORK) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & EDGELOCNBR, MYWORKID, & BASE INTEGER, POINTER :: VERTLOCTAB(:), & EDGELOCTAB(:) DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) IF(MUMPS_795(WORK) .LT. ID%N*3) THEN WRITE(LP, & '("Insufficient workspace inside DMUMPS_719")') CALL MUMPS_ABORT() END IF IF(ord%SUBSTRAT .EQ. 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=n{sep=/(vert>120)?'// & '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=f{cmin=15,cmax=100000,frat=0.0},ose=g}}' ELSE 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 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_733(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, & MAXMEM #endif DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO DO I=BASE, BASE+ord%NSLAVES-2 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) END DO FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* & (BASE+ord%NSLAVES-1-BASE)+1 LAST(BASE+ord%NSLAVES) = id%N DO I=BASE+ord%NSLAVES, NPROCS-1 FIRST(I+1) = id%N+1 LAST(I+1) = id%N END DO VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 VERTLOCTAB => WORK(1:id%N) SWORK => WORK(id%N+1:3*id%N) CALL DMUMPS_776(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%RANGTAB, id%N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%TREETAB, id%N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT permtab:',MEMCNT,MAXMEM #endif IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF IF(ord%IDO) THEN CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in dgraph init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), VERTLOCTAB(1), & VERTLOCTAB(1), EDGELOCNBR, EDGELOCNBR, EDGELOCTAB(1), & EDGELOCTAB(1), EDGELOCTAB(1), IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in dgraph build")') CALL MUMPS_ABORT() END IF CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in strat init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in strat build")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order init")') CALL MUMPS_ABORT() END IF CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order compute")') CALL MUMPS_ABORT() END IF IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB, ord%PERITAB, ord%CBLKNBR, ord%RANGTAB, & ord%TREETAB, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in Corder init")') CALL MUMPS_ABORT() END IF END IF IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order gather")') CALL MUMPS_ABORT() END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN WRITE(LP,'("Error in order gather")') CALL MUMPS_ABORT() END IF END IF END IF IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERITAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB, id%N+1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%TREETAB, id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_777(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM #endif ord%N = id%N ord%COMM = id%COMM CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM #endif RETURN END SUBROUTINE DMUMPS_719 #endif FUNCTION DMUMPS_793(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: DMUMPS_793 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 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF DMUMPS_793 = .FALSE. IF(NACTIVE .GE. RPROC) THEN DMUMPS_793 = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN DMUMPS_793 = .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 NZ_ROW = 2*(id%NZ/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_793 = .TRUE. RETURN ELSE DMUMPS_793 = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION DMUMPS_793 FUNCTION DMUMPS_779(NODE, ord) IMPLICIT NONE INTEGER :: DMUMPS_779 INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR DMUMPS_779 = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE DMUMPS_779 = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN DMUMPS_779 = DMUMPS_779+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION DMUMPS_779 SUBROUTINE DMUMPS_781(ord, id) USE TOOLS_COMMON 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 ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1)) ALIST(1) = ord%CBLKNBR AWEIGHTS(1) = ord%NW(ord%CBLKNBR) NACTIVE = 1 RPROC = NNODES ANODE = 0 PEAKMEM = 0 CALL MUMPS_733(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%FIRST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ord%LAST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')ord%myid,'MEMCNT topnodes:',MEMCNT, & MAXMEM #endif ord%TOPNODES = 0 IF((ord%CBLKNBR .EQ. 1) .OR. & ( RPROC .LT. DMUMPS_779(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 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = DMUMPS_779(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_793(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_783(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL DMUMPS_784(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_783(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL DMUMPS_784(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_781 SUBROUTINE DMUMPS_720(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, POINTER :: PE(:), IPE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & RCVCNT(:), LSTVAR(:) INTEGER, POINTER :: NROOTS(:), MYLIST(:), & MYNVAR(:), LVARPT(:), & DISPLS(:), LPERM(:), & LIPERM(:), & IPET(:), NVT(:), BUF_PE1(:), & BUF_PE2(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP1(:), TMP2(:), BWORK(:) INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, MYNROOTS, PNT, TMP, & NCLIQUES, NTVAR, PFREES, PFREET, TGSIZE, MAXS, RHANDPE, & RHANDNV, STATUSPE(MPI_STATUS_SIZE), & STATUSNV(MPI_STATUS_SIZE), RIDX, PROC, NBBUCK, & PFS_SAVE, PFT_SAVE LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, RCVCNT, LSTVAR) nullify(NROOTS, MYLIST, MYNVAR, LVARPT, DISPLS, & 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_795(WORK) .LT. 4*id%N) THEN WRITE(LP,*)'Insufficient workspace in DMUMPS_720' 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_781(ord, id) CALL MUMPS_734(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))') myid,'deall son:',MEMCNT,MAXMEM #endif 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_775(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK) 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_733(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT allsub:',MEMCNT,MAXMEM #endif 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 IF (ord%SUBSTRAT .EQ. 0) THEN DO I=1, HIDX PERM(I) = I END DO CALL MUMPS_420(1, THRESH, NDENSE(1), HIDX, & MUMPS_795(PE), 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) ELSE NBBUCK = 2*TMP CALL MUMPS_419 (ord%SUBSTRAT, 1, .FALSE., HIDX, NBBUCK, & MUMPS_795(PE), IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), PERM(1), NEXT(1), & W(1), HEAD(1), AGG6, SIZE_SCHUR, LISTVAR_SCHUR(1) ) DO I=1, HIDX PERM(I) = I END DO END IF CALL MUMPS_733(W, 2*NPROCS, id%INFO, & LP, STRING='W', MEMCNT=MEMCNT, ERRCODE=-7) if(MEMCNT .gt. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT w:',MEMCNT,MAXMEM #endif NROOTS => W DISPLS => W(NPROCS+1:2*NPROCS) MYNVAR => DEGREE MYLIST => NDENSE LVARPT => NEXT RCVCNT => HEAD LSTVAR => LAST NULLIFY(W, DEGREE, NDENSE, NEXT, HEAD, LAST) MYNROOTS = 0 PNT = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN PNT = PNT+LENG(I) MYNROOTS = MYNROOTS+1 END IF END DO CALL MUMPS_733(MYLIST, PNT, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT mylist:',MEMCNT,MAXMEM #endif MYNROOTS = 0 PNT = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYNROOTS = MYNROOTS+1 MYNVAR(MYNROOTS) = LENG(I) DO J=1, LENG(I) MYLIST(PNT+J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO PNT = PNT+LENG(I) END IF END DO CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_GATHER(MYNROOTS, 1, MPI_INTEGER, NROOTS(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) IF(MYID .EQ.0) THEN DISPLS(1) = 0 DO I=2, NPROCS DISPLS(I) = DISPLS(I-1)+NROOTS(I-1) END DO NCLIQUES = sum(NROOTS(1:NPROCS)) CALL MUMPS_733(LVARPT, NCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ELSE CALL MUMPS_733(LVARPT, 2, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT lvarpt:',MEMCNT,MAXMEM #endif CALL MPI_GATHERV(MYNVAR(1), MYNROOTS, MPI_INTEGER, LVARPT(2), & NROOTS(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) IF(MYID .EQ. 0) THEN DO I=1, NPROCS RCVCNT(I) = sum(LVARPT(2+DISPLS(I):2+DISPLS(I)+NROOTS(I)-1)) IF(I .EQ. 1) THEN DISPLS(I) = 0 ELSE DISPLS(I) = DISPLS(I-1)+RCVCNT(I-1) END IF END DO CALL MUMPS_733(LSTVAR, sum(RCVCNT(1:NPROCS)), id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT lstvar:',MEMCNT,MAXMEM #endif END IF CALL MPI_GATHERV(MYLIST(1), PNT, MPI_INTEGER, LSTVAR(1), & RCVCNT(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) NULLIFY(DISPLS) IF(MYID .EQ. 0) THEN LVARPT(1) = 1 DO I=2, NCLIQUES+1 LVARPT(I) = LVARPT(I-1) + LVARPT(I) END DO LPERM => WORK(3*id%N+1 : 4*id%N) NTVAR = ord%TOPNODES(2) CALL DMUMPS_782(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL DMUMPS_774(id, ord%TOPNODES(2), LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPET, PE, LENG, ELEN) TGSIZE = ord%TOPNODES(2)+NCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) CALL MUMPS_734(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) W => NROOTS DEGREE => MYNVAR NDENSE => MYLIST NEXT => LVARPT HEAD => RCVCNT LAST => LSTVAR NULLIFY(NROOTS, MYNVAR, MYLIST, LVARPT, RCVCNT, LSTVAR) CALL MUMPS_733(PE, max(PFREET+TGSIZE,1), id%INFO, LP, & COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LISTVAR_SCHUR, max(NCLIQUES,1), id%INFO, LP, & STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT pe:',MEMCNT,MAXMEM #endif DO I=1, NCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 IF(ord%TOPSTRAT .EQ. 0) THEN CALL MUMPS_733(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rehead:',MEMCNT,MAXMEM #endif DO I=1, TGSIZE PERM(I) = I END DO CALL MUMPS_420(2, -1, NDENSE(1), TGSIZE, & MUMPS_795(PE), 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), NCLIQUES, & AGG6) ELSE NBBUCK = 2*TGSIZE CALL MUMPS_733(HEAD, NBBUCK+2, id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(PERM, TGSIZE, id%INFO, & LP, STRING='J2:PERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rehead:',MEMCNT,MAXMEM #endif CALL MUMPS_419 (ord%TOPSTRAT, 2, .FALSE., TGSIZE, & NBBUCK, MUMPS_795(PE), IPET(1), PFREET, LENG(1), & PE(1), NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), & PERM(1), NEXT(1), W(1), HEAD(1), AGG6, NCLIQUES, & LISTVAR_SCHUR(1) ) END IF END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MUMPS_734(LISTVAR_SCHUR, PE, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall lvs:',MEMCNT,MAXMEM #endif IF(MYID .EQ. 0) THEN BUF_PE1 => WORK( 1 : id%N) BUF_PE2 => WORK( id%N+1 : 2*id%N) BUF_NV1 => WORK(2*id%N+1 : 3*id%N) BUF_NV2 => WORK(3*id%N+1 : 4*id%N) 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_733(BUF_PE1, MAXS, id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_PE2, MAXS, id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_NV1, MAXS, id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(BUF_NV2, MAXS, id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(GPE, id%N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(GNV, id%N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ROOTPERM, NCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT buf_pe1:',MEMCNT, & MAXMEM #endif 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_INTEGER, 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, NCLIQUES 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_INTEGER, 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_734(PE, IPE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_734(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_734(LSTVAR, NROOTS, MYLIST, MYNVAR, & LVARPT, MEMCNT=MEMCNT) CALL MUMPS_734(LPERM, LIPERM, IPET, NVT, & MEMCNT=MEMCNT) CALL MUMPS_734(ROOTPERM, TMP1, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, RCVCNT) RETURN END SUBROUTINE DMUMPS_720 SUBROUTINE DMUMPS_782(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_733(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT lperm:',MEMCNT, & MAXMEM #endif 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_782 SUBROUTINE DMUMPS_774(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(:), LVARPT(:), & IPE(:), PE(:), LENG(:), ELEN(:) INTEGER :: NCLIQUES INTEGER :: I, J, IDX, NLOCVARS, PNT, SAVEPNT CALL MUMPS_733(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT leng:',MEMCNT, & MAXMEM #endif LENG = 0 ELEN = 0 DO I=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN LENG(LPERM(top_graph%IRN_LOC(I))) = & LENG(LPERM(top_graph%IRN_LOC(I))) + 1 END IF END DO DO I=1, NCLIQUES DO J=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+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)+LENG(I)+ELEN(I) END DO CALL MUMPS_733(PE, IPE(NLOCVARS+NCLIQUES+1)+NLOCVARS+NCLIQUES, & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT repe:',MEMCNT, & MAXMEM #endif LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO J=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(J)) PE(IPE(IDX)+ELEN(IDX)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+LENG(NLOCVARS+I)) = IDX ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO I=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN PE(IPE(LPERM(top_graph%IRN_LOC(I)))+ & ELEN(LPERM(top_graph%IRN_LOC(I))) + & LENG(LPERM(top_graph%IRN_LOC(I)))) = & LPERM(top_graph%JCN_LOC(I)) LENG(LPERM(top_graph%IRN_LOC(I))) = & LENG(LPERM(top_graph%IRN_LOC(I))) + 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 J=IPE(I), IPE(I+1)-1 IF(LPERM(PE(J)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE DMUMPS_774 SUBROUTINE DMUMPS_778(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:2) = (/1, 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_778 SUBROUTINE DMUMPS_776(id, FIRST, LAST, IPE, & PE, WORK) IMPLICIT NONE INCLUDE 'mpif.h' TYPE(DMUMPS_STRUC) :: id INTEGER, POINTER :: FIRST(:), LAST(:), IPE(:), PE(:), & WORK(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, LOCNNZ, & NEW_LOCNNZ, J, LOC_ROW INTEGER :: TOP_CNT, TIDX, & NROWS_LOC, DUPS, TOTDUPS, OFFDIAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), & SNDCNT(:), RCVCNT(:), SDISPL(:) INTEGER, POINTER :: RDISPL(:), & MSGCNT(:), SIPES(:,:), LENG(:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, & SAVEPNT INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL) nullify(RDISPL, MSGCNT, SIPES, LENG) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_795(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_733(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT sndcnt:',MEMCNT,MAXMEM #endif ALLOCATE(APNT(NPROCS)) SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 1000 LOCNNZ = id%NZ_loc 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 I=1, id%NZ_loc IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(I)) LOC_ROW = id%IRN_loc(I)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(I)) LOC_ROW = id%JCN_loc(I)-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%KEEP(114), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) id%KEEP(114) = id%KEEP(114)+3*id%N id%KEEP(113) = id%KEEP(114)-2*id%N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, id%COMM, IERR) SNDCNT(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) CALL MUMPS_733(IPE, NROWS_LOC+1, id%INFO, & LP, STRING='IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT ripe:',MEMCNT,MAXMEM #endif IPE(1) = 1 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + LENG(I) END DO CALL MUMPS_733(PE, max(IPE(NROWS_LOC+1)-1,1), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe:',MEMCNT,MAXMEM #endif LENG(:) = 0 CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) NEW_LOCNNZ = sum(RCVCNT) DO I=1, NPROCS MSGCNT(I) = RCVCNT(I)/BUFSIZE END DO RCVPNT = 1 SNDCNT = 0 TIDX = 0 DO I=1, id%NZ_loc IF(mod(I,BUFSIZE/10) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, MPI_COMM_WORLD, STATUS, IERR) CALL DMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%IRN_loc(I)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%JCN_loc(I) SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF PROC = MAPTAB(id%JCN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%JCN_loc(I)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%IRN_loc(I) SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF END DO CALL DMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO J=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(J)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER, MPI_SUM, & 0, id%COMM, IERR ) SYMMETRY = dble(TOTDUPS)/(dble(id%NZ)-dble(id%N)) IF(MYID .EQ. 0) THEN IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'("Structual symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_734(SNDCNT, RCVCNT, MSGCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM #endif RETURN END SUBROUTINE DMUMPS_776 SUBROUTINE DMUMPS_775(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK) IMPLICIT NONE INCLUDE 'mpif.h' TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: IPE(:), PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, LOCNNZ, & NEW_LOCNNZ, J, LOC_ROW INTEGER :: TOP_CNT,IIDX,JJDX INTEGER :: HALO_SIZE, TIDX, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), & SNDCNT(:), RCVCNT(:), & SDISPL(:), HALO_MAP(:) INTEGER, POINTER :: RDISPL(:), & MSGCNT(:), SIPES(:,:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, & SAVEPNT INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_795(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_733(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rrsndcnt:',MEMCNT,MAXMEM #endif ALLOCATE(APNT(NPROCS)) SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 LOCNNZ = id%NZ_loc 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 I=1, id%NZ_loc IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(I)) 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(I)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(I)) 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_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, id%COMM, IERR) I = ceiling(dble(MAXS)*1.20D0) CALL MUMPS_733(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrleng2:',MEMCNT, & MAXMEM #endif SNDCNT(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(dble(NROWS_LOC+1)*1.20D0) CALL MUMPS_733(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT rripe:',MEMCNT,MAXMEM #endif IPE(1) = 1 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + LENG(I) END DO CALL MUMPS_733(TSENDI, max(TOP_CNT,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(TSENDJ, max(TOP_CNT,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT tsendi:',MEMCNT,MAXMEM #endif LENG(:) = 0 CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) NEW_LOCNNZ = sum(RCVCNT) DO I=1, NPROCS MSGCNT(I) = RCVCNT(I)/BUFSIZE END DO CALL MUMPS_733(PE, max(NEW_LOCNNZ+2*NROWS_LOC,1), id%INFO, & LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe2:',MEMCNT,MAXMEM #endif RCVPNT = 1 SNDCNT = 0 TIDX = 0 DO I=1, id%NZ_loc IF(mod(I,BUFSIZE/10) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, MPI_COMM_WORLD, STATUS, IERR) CALL DMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN PROC = MAPTAB(id%IRN_loc(I)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(I) TSENDJ(TIDX) = id%JCN_loc(I) ELSE IIDX = ord%PERMTAB(id%IRN_loc(I)) JJDX = ord%PERMTAB(id%JCN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) =IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%JCN_loc(I) END IF SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(I)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(I) TSENDJ(TIDX) = id%IRN_loc(I) ELSE IIDX = ord%PERMTAB(id%JCN_loc(I)) JJDX = ord%PERMTAB(id%IRN_loc(I)) APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%IRN_loc(I) END IF SNDCNT(PROC) = SNDCNT(PROC)+1 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) END IF END IF END IF END DO CALL DMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, SNDCNT, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO J=IPE(I),IPE(I+1)-1 IF(PE(J) .LT. 0) THEN IF(HALO_MAP(-PE(J)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(J)) = NROWS_LOC+HALO_SIZE END IF PE(J) = HALO_MAP(-PE(J)) END IF IF(MAPTAB(PE(J)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(J)) = I PNT = PNT+1 PE(PNT) = PE(J) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_733(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid, & 'MEMCNT i_halo:',MEMCNT,MAXMEM #endif 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_733(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_733(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT lengipe:',MEMCNT, & MAXMEM #endif 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_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) RDISPL => MSGCNT NULLIFY(MSGCNT) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) RDISPL(1) = 0 DO I=2, NPROCS RDISPL(I) = RDISPL(I-1)+RCVCNT(I-1) END DO top_graph%NZ_LOC = NEW_LOCNNZ top_graph%COMM = id%COMM CALL MUMPS_733(top_graph%IRN_LOC, NEW_LOCNNZ, id%INFO, & LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_733(top_graph%JCN_LOC, NEW_LOCNNZ, id%INFO, & LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT top_graph:',MEMCNT, & MAXMEM #endif ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1)) END IF CALL MPI_GATHERV(TSENDI(1), TOP_CNT, MPI_INTEGER, & top_graph%IRN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, & 0, id%COMM, IERR) CALL MPI_GATHERV(TSENDJ(1), TOP_CNT, MPI_INTEGER, & top_graph%JCN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, & 0, id%COMM, IERR) CALL MUMPS_734(SNDCNT, RCVCNT, RDISPL, & TSENDI, TSENDJ, MEMCNT=MEMCNT) #if defined (memprof) write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM #endif DEALLOCATE(APNT) RETURN END SUBROUTINE DMUMPS_775 SUBROUTINE DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER :: NPROCS, PROC, COMM TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:), IPE(:) INTEGER :: MSGCNT(:), SNDCNT(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE, TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE), & 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_773(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_773(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_773(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_785 SUBROUTINE DMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) #ifdef MPELOG USE MPEMOD INCLUDE 'mpif.h' #endif IMPLICIT NONE INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), IPE(:), PE(:), LENG(:) INTEGER :: I, ROW, COL #ifdef MPELOG INTEGER ::IERR IERR = MPE_LOG_EVENT( MPE_ASM_BUF1, 0, '' ) #endif 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 #ifdef MPELOG IERR = MPE_LOG_EVENT( MPE_ASM_BUF2, 0, '' ) #endif RETURN END SUBROUTINE DMUMPS_773 SUBROUTINE DMUMPS_777(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_777 SUBROUTINE DMUMPS_784(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_784 SUBROUTINE DMUMPS_783(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_783 FUNCTION MUMPS_795(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_795 IF(associated(A)) THEN MUMPS_795 = size(A) ELSE MUMPS_795 = 0 END IF RETURN END FUNCTION MUMPS_795 SUBROUTINE MUMPS_734(A1, A2, A3, A4, A5, A6, A7, MEMCNT) INTEGER, POINTER :: A1(:) INTEGER, POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:), & A6(:), A7(:) INTEGER, OPTIONAL :: MEMCNT INTEGER :: IMEMCNT IMEMCNT = 0 IF(associated(A1)) THEN IMEMCNT = IMEMCNT+size(A1) DEALLOCATE(A1) END IF IF(present(A2)) THEN IF(associated(A2)) THEN IMEMCNT = IMEMCNT+size(A2) DEALLOCATE(A2) END IF END IF IF(present(A3)) THEN IF(associated(A3)) THEN IMEMCNT = IMEMCNT+size(A3) DEALLOCATE(A3) END IF END IF IF(present(A4)) THEN IF(associated(A4)) THEN IMEMCNT = IMEMCNT+size(A4) DEALLOCATE(A4) END IF END IF IF(present(A5)) THEN IF(associated(A5)) THEN IMEMCNT = IMEMCNT+size(A5) DEALLOCATE(A5) END IF END IF IF(present(A6)) THEN IF(associated(A6)) THEN IMEMCNT = IMEMCNT+size(A6) DEALLOCATE(A6) END IF END IF IF(present(A7)) THEN IF(associated(A7)) THEN IMEMCNT = IMEMCNT+size(A7) DEALLOCATE(A7) END IF END IF IF(present(MEMCNT)) MEMCNT = MEMCNT-IMEMCNT RETURN END SUBROUTINE MUMPS_734 #if defined(memprof) FUNCTION ESTIMEM(MYID, N, NZR) INTEGER :: ESTIMEM, MYID, NZR, N IF(MYID.EQ.0) THEN ESTIMEM = 12*N ELSE ESTIMEM = 7*N END IF IF(MYID.NE.0) TOPROWS=0 IF(MYID .EQ. 0) ESTIMEM = ESTIMEM+2*TOPROWS*NZR ESTIMEM = ESTIMEM+NRL ESTIMEM = ESTIMEM+max(NRL,TOPROWS)*(NZR+2) ESTIMEM = ESTIMEM+6*max(NRL,TOPROWS) IF(MYID.EQ.0) ESTIMEM=ESTIMEM+3*TOPROWS RETURN END FUNCTION ESTIMEM #endif END MODULE SUBROUTINE DMUMPS_448(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_448 SUBROUTINE DMUMPS_444 & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER M,N,NE,NUM INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),PR(N),Q(M),L(M) DOUBLE PRECISION A(NE) DOUBLE PRECISION D(M), RINF INTEGER I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & K,KK,KK1,KK2,I0,UP,LOW 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_445, DMUMPS_446, DMUMPS_447, DMUMPS_455 RLX = D(1) NUM = 0 BV = RINF DO 10 K = 1,N JPERM(K) = 0 PR(K) = IP(K) 10 CONTINUE DO 12 K = 1,M IPERM(K) = 0 D(K) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1 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 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 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 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1 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 DO 115 K = IP(J),IP(J+1)-1 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_445(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = J 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_446(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 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_447(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_445(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = J 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 = PR(J) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 KK = UP,M I = Q(KK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 KK = LOW,UP-1 I = Q(KK) D(I) = MINONE 192 CONTINUE DO 193 KK = 1,QLEN I = Q(KK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL DMUMPS_455(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE DMUMPS_444 SUBROUTINE DMUMPS_445(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_445 SUBROUTINE DMUMPS_446(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_446 SUBROUTINE DMUMPS_447(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_447 SUBROUTINE DMUMPS_450(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER WLEN,NVAL INTEGER IP(*),LENL(*),LENH(*),W(*) DOUBLE PRECISION A(*),VAL INTEGER XX,J,K,II,S,POS PARAMETER (XX=10) DOUBLE PRECISION SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+LENL(J),IP(J)+LENH(J)-1 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_450 SUBROUTINE DMUMPS_451(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER N,NE INTEGER IP(N+1),IRN(NE) DOUBLE PRECISION A(NE) INTEGER THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER J,IPJ,K,LEN,R,S,HI,FIRST,MID,LAST,TD DOUBLE PRECISION HA,KEY INTEGER TODO(TDLEN) DO 100 J = 1,N LEN = 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 + LEN TD = 2 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 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 425 CONTINUE IF (TD.EQ.0) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.THRESH) GO TO 500 TD = TD - 2 GO TO 425 400 DO 200 R = IPJ+1,IPJ+LEN-1 IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1) IRN(R) = IRN(R-1) DO 300 S = R-1,IPJ+1,-1 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_451 SUBROUTINE DMUMPS_452(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER M,N,NE,NUMX INTEGER IP(N+1),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,II,I,J,K,L,CNT,MOD,IDUM1,IDUM2,IDUM3 DOUBLE PRECISION BVAL,BMIN,BMAX EXTERNAL DMUMPS_450,DMUMPS_453,DMUMPS_455 DO 20 J = 1,N FC(J) = J LEN(J) = 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_453(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 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 = IP(J+1) - IP(J) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = K - IP(J) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 IDUM1 = 1,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 IDUM2 = 1,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL DMUMPS_450(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM3 = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+LEN(J)-1,IP(J)+LENL(J),-1 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) = 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_450(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM3 = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+LEN(J),IP(J)+LENH(J)-1 IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = 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_453(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_455(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE DMUMPS_452 SUBROUTINE DMUMPS_453 & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER ID,MOD,M,N,LIRN,NUM,NUMX INTEGER ARP(N),CV(M),IRN(LIRN),IP(N), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK,LAST,NFC, & NUM0,NUM1,NUM2,ID0,ID1 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) + ARP(J) IN2 = IP(J) + LENC(J) - 1 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 = OUT(J) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + LENC(J) - 1 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) = 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) = 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) + LENC(J) - OUT(J) - 2 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_453 SUBROUTINE DMUMPS_454(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER M,N,NE,NUM INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),OUT(N),PR(N),Q(M),L(M) DOUBLE PRECISION A(NE),U(M),D(M),RINF,RINF3 INTEGER I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,ISP,JSP, & K,K0,K1,K2,KK,KK1,KK2,UP,LOW DOUBLE PRECISION CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL LORD DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) EXTERNAL DMUMPS_445, DMUMPS_446, DMUMPS_447, DMUMPS_455 RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 K = 1,N JPERM(K) = 0 PR(K) = IP(K) D(K) = RINF 10 CONTINUE DO 15 K = 1,M U(K) = RINF3 IPERM(K) = 0 L(K) = 0 15 CONTINUE DO 30 J = 1,N IF (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) 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 K = 1,M D(K) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1 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 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 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF L(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 DO 115 K = IP(J),IP(J+1)-1 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 Q(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 KK = 1,Q0 K = Q(KK) 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 Q(LOW) = I L(I) = LOW ELSE QLEN = QLEN + 1 L(I) = QLEN CALL DMUMPS_445(I,M,Q,D,L,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = J 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL DMUMPS_446(QLEN,M,Q,D,L,2) LOW = LOW - 1 Q(LOW) = I L(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = Q(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 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 (L(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 (L(I).NE.0) THEN CALL DMUMPS_447(L(I),QLEN,M,Q,D,L,2) ENDIF LOW = LOW - 1 Q(LOW) = I L(I) = LOW ELSE IF (L(I).EQ.0) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL DMUMPS_445(I,M,Q,D,L,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = J 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 = 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 KK = UP,M I = Q(KK) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 KK = UP,M I = Q(KK) D(I) = RINF L(I) = 0 191 CONTINUE DO 192 KK = LOW,UP-1 I = Q(KK) D(I) = RINF L(I) = 0 192 CONTINUE DO 193 KK = 1,QLEN I = Q(KK) D(I) = RINF L(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_455(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE DMUMPS_454 SUBROUTINE DMUMPS_457 & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER LIRN,M,N,NUM INTEGER ARP(N),CV(M),IRN(LIRN),IP(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK EXTERNAL DMUMPS_455 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 = ARP(J) IF (IN1.LT.0) GO TO 30 IN2 = IP(J) + LENC(J) - 1 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 = OUT(J) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + LENC(J) - 1 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) = IN2 - II - 1 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) = IN2 - II - 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 1000 II = IP(J) + LENC(J) - OUT(J) - 2 I = IRN(II) IPERM(I) = J 90 CONTINUE 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL DMUMPS_455(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE DMUMPS_457 SUBROUTINE DMUMPS_455(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_455 mumps-4.10.0.dfsg/src/cmumps_ooc_buffer.F0000644000175300017530000004463311562233067020513 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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 INTEGER IO_STRAT 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_689(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_689 SUBROUTINE CMUMPS_707(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL CMUMPS_696(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_689(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE CMUMPS_707 SUBROUTINE CMUMPS_675(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_707(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL CMUMPS_707(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_675 SUBROUTINE CMUMPS_696(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_677(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_677(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_696 SUBROUTINE CMUMPS_669(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_731(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_686() ELSE CALL CMUMPS_685() ENDIF RETURN END SUBROUTINE CMUMPS_669 SUBROUTINE CMUMPS_659() 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_659 SUBROUTINE CMUMPS_685() 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_689(OOC_FCT_TYPE_LOC) END SUBROUTINE CMUMPS_685 SUBROUTINE CMUMPS_678(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_707(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_678 SUBROUTINE CMUMPS_686() 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_689(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE CMUMPS_686 SUBROUTINE CMUMPS_706(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_696(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL CMUMPS_689(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_706 SUBROUTINE CMUMPS_709 (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_709 SUBROUTINE CMUMPS_653( 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_653: 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_707(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL CMUMPS_706(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'CMUMPS_653: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL CMUMPS_709 (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_653 END MODULE CMUMPS_OOC_BUFFER mumps-4.10.0.dfsg/src/zmumps_ooc.F0000644000175300017530000035550711562233070017210 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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 #if defined (NEW_PREF_SCHEME) INTEGER,SAVE :: MAX_PREF_SIZE #endif & ,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_575,ZMUMPS_576, & ZMUMPS_577, & ZMUMPS_578, & ZMUMPS_579, & ZMUMPS_582, & ZMUMPS_583,ZMUMPS_584, & ZMUMPS_585,ZMUMPS_586 INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC ZMUMPS_688, & ZMUMPS_690 PRIVATE ZMUMPS_695, & ZMUMPS_697 CONTAINS SUBROUTINE ZMUMPS_711( 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_711 FUNCTION ZMUMPS_579(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL ZMUMPS_579 ZMUMPS_579=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION ZMUMPS_579 SUBROUTINE ZMUMPS_590(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE ZMUMPS_590 SUBROUTINE ZMUMPS_575(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*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 CALL ZMUMPS_588(id,IERR) 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_796(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_711( 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_669(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_589(TMP_DIR(1), & id%OOC_TMPDIR, TMPDIR_MAX_LENGTH, DIM_DIR ) CALL ZMUMPS_589(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,kind=4)+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_575 SUBROUTINE ZMUMPS_576(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_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_678 & (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_707(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_707(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_689(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_576 SUBROUTINE ZMUMPS_577(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE COMPLEX(kind=8) DEST INTEGER ASYNC LOGICAL IO_C #if defined(OLD_READ) INTEGER REQUEST #endif 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. #if ! defined(OLD_READ) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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 #else OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) 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 ) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_READ_OOC' ENDIF RETURN 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 #endif 555 CONTINUE IF(.NOT.ZMUMPS_727())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_728() ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_577 SUBROUTINE ZMUMPS_591(IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL ZMUMPS_675(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE ZMUMPS_591 SUBROUTINE ZMUMPS_592(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_659() 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_613(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_592 SUBROUTINE ZMUMPS_588(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*1 TMP_NAME(350) IERR=0 K=1 IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,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 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_588 SUBROUTINE ZMUMPS_587(id,IERR) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER IERR IERR=0 CALL ZMUMPS_588(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_587 SUBROUTINE ZMUMPS_586(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_275 INTEGER MUMPS_275 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_VADDR) ENDIF CALL MUMPS_796(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_614(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_586' 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_711( 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_586' id%INFO(1) = -11 CALL MUMPS_731(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_586' 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_586' 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_586' 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_586' 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_275( & 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_275( & 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 #if defined (NEW_PREF_SCHEME) MAX_PREF_SIZE=(1024*1024*2)/8 #endif RETURN END SUBROUTINE ZMUMPS_586 SUBROUTINE ZMUMPS_585(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_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL ZMUMPS_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_585 SUBROUTINE ZMUMPS_594(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_603(ZONE) IERR=0 CALL ZMUMPS_611(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE ZMUMPS_594 SUBROUTINE ZMUMPS_595(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_677(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_677(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_597(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL ZMUMPS_597(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_596(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE ZMUMPS_595 SUBROUTINE ZMUMPS_596(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_330,MUMPS_275 INTEGER MUMPS_330,MUMPS_275 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_330(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_275( & 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_330(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & SLAVEF_OOC).EQ.2).AND.(MUMPS_275( & 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_596 SUBROUTINE ZMUMPS_597(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_596(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_597',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_597',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_597 ',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_597 SUBROUTINE ZMUMPS_598(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_598', & 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_600(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_608(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_601(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_594(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL ZMUMPS_603(ZONE) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_598 FUNCTION ZMUMPS_726(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_726 IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN ZMUMPS_726=OOC_NODE_PERMUTED ELSE ZMUMPS_726=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.ZMUMPS_727())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_728() 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_596(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL ZMUMPS_599(INODE,PTRFAC,NSTEPS) IF(.NOT.ZMUMPS_727())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_728() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN ZMUMPS_726=OOC_NODE_PERMUTED ELSE ZMUMPS_726=OOC_NODE_NOT_PERMUTED ENDIF ELSE ZMUMPS_726=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION ZMUMPS_726 SUBROUTINE ZMUMPS_682(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_682 SUBROUTINE ZMUMPS_599(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_610(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_609(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE ZMUMPS_599 SUBROUTINE ZMUMPS_600(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_600 SUBROUTINE ZMUMPS_601(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE ZMUMPS_601 SUBROUTINE ZMUMPS_603(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_603 SUBROUTINE ZMUMPS_578(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_608(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_606(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(ZMUMPS_579(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL ZMUMPS_604(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_606(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL ZMUMPS_605(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL ZMUMPS_605(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_607(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL ZMUMPS_604(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_606(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL ZMUMPS_608(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_606(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_578 SUBROUTINE ZMUMPS_604(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_604', & 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_596( & 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_604' 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_604' 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_604 SUBROUTINE ZMUMPS_605(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_605', & 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_596( & 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_605' 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_605' 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_596( & 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_605' 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_605 SUBROUTINE ZMUMPS_606(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_606 SUBROUTINE ZMUMPS_607(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_607' 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_607 SUBROUTINE ZMUMPS_608(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_608',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_596( & 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_596( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' ZMUMPS_608',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_596( & 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_608 SUBROUTINE ZMUMPS_609(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_609' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_610(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_609 SUBROUTINE ZMUMPS_610(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_610 FUNCTION ZMUMPS_727() IMPLICIT NONE LOGICAL ZMUMPS_727 ZMUMPS_727=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN ZMUMPS_727=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN ZMUMPS_727=.TRUE. ENDIF ENDIF RETURN END FUNCTION ZMUMPS_727 SUBROUTINE ZMUMPS_611(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_727())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_727())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL ZMUMPS_728() 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_727())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL ZMUMPS_728() 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_604(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_605(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_605(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_604(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_608(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL ZMUMPS_602(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_595(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE ZMUMPS_611 SUBROUTINE ZMUMPS_602(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_727())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_602',FLAG CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_728() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 #if defined (NEW_PREF_SCHEME) IF(MAX_SIZE.GT.MAX_PREF_SIZE)THEN MAX_SIZE=MIN(MAX(MAX_PREF_SIZE, & SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE)), & MAX_SIZE) ENDIF #endif 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_602 SUBROUTINE ZMUMPS_582(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_582 SUBROUTINE ZMUMPS_612(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_600(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).OR.(J.NE.SPECIAL_ROOT_NODE) & .OR.(ZONE.NE.NB_Z))THEN CALL ZMUMPS_599(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.ALREADY_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_599(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_608(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_608 =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_612 SUBROUTINE ZMUMPS_583(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_808 EXTERNAL MUMPS_808 IERR = 0 OOC_FCT_TYPE=MUMPS_808("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_612(PTRFAC,NSTEPS,A,LA) ELSE CALL ZMUMPS_683(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL ZMUMPS_585(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE ZMUMPS_583 SUBROUTINE ZMUMPS_584(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_808 EXTERNAL MUMPS_808 IERR=0 OOC_FCT_TYPE=MUMPS_808("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_612(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT) THEN CALL ZMUMPS_598 ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN CALL ZMUMPS_600(IROOT, & ZONE,PTRFAC,NSTEPS) IF(IROOT.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL ZMUMPS_608(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & ZMUMPS_608', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL ZMUMPS_594(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL ZMUMPS_683(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL ZMUMPS_585(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_584 SUBROUTINE ZMUMPS_613(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*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_613' 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_613' 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_613 SUBROUTINE ZMUMPS_614(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC), TARGET :: id CHARACTER*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_614' 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_614 SUBROUTINE ZMUMPS_589(DEST,SRC,NB,NB_EFF) IMPLICIT NONE INTEGER NB, NB_EFF CHARACTER(LEN=NB) SRC CHARACTER*1 DEST(NB) INTEGER I DO I=1,NB_EFF DEST(I)=SRC(I:I) ENDDO END SUBROUTINE ZMUMPS_589 SUBROUTINE ZMUMPS_580(IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL ZMUMPS_707(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_580 SUBROUTINE ZMUMPS_681(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_707(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE ZMUMPS_681 SUBROUTINE ZMUMPS_683(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_683 SUBROUTINE ZMUMPS_688 & ( 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_695( 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_695( 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_688 SUBROUTINE ZMUMPS_695( 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_690(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = ZMUMPS_725 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = ZMUMPS_725 & (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_695 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_695,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_695', & 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_695 ', & ' 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_697( 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_695 ', & ' 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_695" 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_695 SUBROUTINE ZMUMPS_697( & 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_653( 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_697 INTEGER(8) FUNCTION ZMUMPS_725 & (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_725 = TOTSIZE RETURN END FUNCTION ZMUMPS_725 INTEGER FUNCTION ZMUMPS_690( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER ZMUMPS_748 ZMUMPS_690=ZMUMPS_748( & HBUF_SIZE, NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION ZMUMPS_690 SUBROUTINE ZMUMPS_728() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.ZMUMPS_727())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_728 SUBROUTINE ZMUMPS_809(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_809 END MODULE ZMUMPS_OOC mumps-4.10.0.dfsg/src/dmumps_part8.F0000644000175300017530000102143611562233066017435 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE DMUMPS_301( id) USE DMUMPS_STRUC_DEF USE MUMPS_SOL_ES USE DMUMPS_COMM_BUFFER USE DMUMPS_OOC USE TOOLS_COMMON IMPLICIT NONE INTERFACE SUBROUTINE DMUMPS_710( id, NB_INT,NB_CMPLX ) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC) :: id INTEGER(8) :: NB_INT,NB_CMPLX END SUBROUTINE DMUMPS_710 SUBROUTINE DMUMPS_758 &(idRHS, idINFO, idN, idNRHS, idLRHS) DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE DMUMPS_758 END INTERFACE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE (DMUMPS_STRUC), TARGET :: id INTEGER MP,LP, MPG LOGICAL PROK, PROKG INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, ERANAL, GIVSOL INTEGER ICNTL10, ICNTL11 INTEGER I,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK INTEGER LIW INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER LWCB_MIN, LWCB, LWCB_SOL_C INTEGER(8) :: TMP_LWCB8 INTEGER DMUMPS_LBUF, DMUMPS_LBUF_INT INTEGER MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 INTEGER NITREF, NOITER, SOLVET, KASE, JOBIREF DOUBLE PRECISION RSOL(1) LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 INTEGER :: K220(0:id%NSLAVES) 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 INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, NBT INTEGER :: PERM_PIV_LIST(max(id%KEEP(112),1)) INTEGER :: MAP_PIVNUL_LIST(max(id%KEEP(112),1)) INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS 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 ) DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_MUMPS DOUBLE PRECISION, DIMENSION(:), POINTER :: WORK_WCB DOUBLE PRECISION, DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER :: LPTR_RHS_ROOT DOUBLE PRECISION, ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) DOUBLE PRECISION, ALLOCATABLE :: CWORK(:) DOUBLE PRECISION, ALLOCATABLE :: R_RW1(:), R_Y(:), D(:) DOUBLE PRECISION, ALLOCATABLE :: R_W(:) DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV, & POSINRHSCOMP_N INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) 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 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 DOUBLE PRECISION, DIMENSION(:), POINTER :: PT_SCALING DOUBLE PRECISION, TARGET :: Dummy_SCAL(1) 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, WHAT INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & IBEG, LD_RHS, KDEC, & MASTER_ROOT, MASTER_ROOT_IN_COMM INTEGER IPT_RHS_ROOT, SIZE_ROOT, LD_REDRHS INTEGER IBEG_REDRHS, IBEG_RHSCOMP, LD_RHSCOMP, LENRHSCOMP INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES INTEGER(8) NB_BYTES_MAX INTEGER(8) NB_BYTES_EXTRA INTEGER(8) NB_INT, NB_CMPLX, K34_8, K35_8, NB_BYTES_ON_ENTRY INTEGER(8) K16_8, ITMP8 #if defined(V_T) 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 MUMPS_275 EXTERNAL MUMPS_275 #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 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_MUMPS) 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 RINFOG =>id%RINFOG MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LP = id%ICNTL( 1 ) PROK = (MP.GT.0) PROKG = (MPG.GT.0 .and. id%MYID.eq.MASTER) 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) NB_RHSSKIPPED = 0 LSCAL = .FALSE. WORK_WCB_ALLOCATED = .FALSE. ICNTL21 = -99998 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) CALL DMUMPS_710 (id, NB_INT,NB_CMPLX ) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K35_8 NB_BYTES_ON_ENTRY = NB_BYTES NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID .EQ. MASTER) THEN CALL DMUMPS_807(id) id%KEEP(111) = id%ICNTL(25) id%KEEP(248) = id%ICNTL(20) ICNTL21 = id%ICNTL(21) IF (ICNTL21 .ne.0.and.ICNTL21.ne.1) ICNTL21=0 IF ( id%ICNTL(30) .NE.0 ) THEN id%KEEP(237) = 1 ELSE id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN id%KEEP(248)=1 ENDIF IF (id%KEEP(248) .ne.0.and.id%KEEP(248).ne.1) id%KEEP(248)=0 IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN id%KEEP(248) = 0 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN id%KEEP(235) = 0 ENDIF MTYPE = ICNTL( 9 ) 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(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 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(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF ( id%MYID .EQ. MASTER ) THEN 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 IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN 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 IF (KEEP(252).NE.0 .AND. ICNTL(9).NE.1) THEN 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 INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE INFO(2) = 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 IF ( (id%KEEP(237).EQ.0) ) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. ICNTL21==0) THEN CALL DMUMPS_758 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE 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 IF ((id%NZ_RHS.LE.0).AND.(KEEP(237).NE.0)) THEN 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 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 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 IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN IF (PROKG) THEN write(MPG,*)id%MYID, & " Incompatible values for sparse RHS ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 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 CALL DMUMPS_634(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(111) .NE. 0 .AND. id%KEEP(50) .EQ. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: null space not available for unsymmetric matrices' INFO(1) = -37 INFO(2) = 0 GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN 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 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 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 END IF IF (ICNTL21==1) THEN IF ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) THEN 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 (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 IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1) THEN 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 CALL DMUMPS_769(id) END IF IF (id%INFO(1) .LT. 0) GOTO 333 333 CONTINUE CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 IF ((id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0)) THEN CALL MPI_BCAST(id%NZ_RHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (id%NZ_RHS.EQ.0) THEN IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN LIW_PASSED=max(1,KEEP(32)) IF (KEEP(89) .GT. 0) THEN CALL DMUMPS_535( 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 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 IF ( PROKG ) THEN 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 WRITE (MPG, 153) KEEP(252) ENDIF ENDIF GOTO 90 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(111).NE.0)) THEN KEEP(242) = 0 ENDIF ENDIF INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN IF (LP.GT.0) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF NBT = 0 CALL MUMPS_733(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF (NBT.NE.0) THEN DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE id%Step2node(id%STEP(I)) = I ENDDO ENDIF NB_BYTES = NB_BYTES + int(NBT,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + int(NBT,8) * K34_8 ENDIF IF ( I_AM_SLAVE ) & CALL MUMPS_804(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 IF (id%MYID.EQ.MASTER) THEN IF( KEEP(111)==0 .AND. KEEP(248)==1 ) THEN NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) & NRHS_NONEMPTY = NRHS_NONEMPTY+1 ENDDO IF (NRHS_NONEMPTY.LE.0) THEN IF (LP.GT.0) & WRITE(LP,*) 'Internal error : NRHS_NONEMPTY=', & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF BUILD_POSINRHSCOMP = .TRUE. IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN BUILD_POSINRHSCOMP = .FALSE. ENDIF SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_275( & 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 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_275( & 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 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF IF (id%MYID .eq. MASTER) THEN KEEP(84) = ICNTL(27) IF (KEEP(252).NE.0) THEN 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 ENDIF ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (KEEP(201).GT.0) THEN IF (I_AM_SLAVE) THEN IF (KEEP(201).EQ.1 & .AND.KEEP(50).EQ.0 & .AND.KEEP(251).NE.2 & ) THEN OOC_NB_FILE_TYPE=2 ELSE OOC_NB_FILE_TYPE=1 ENDIF ENDIF 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 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 ) ENDIF IF ( I_AM_SLAVE ) THEN NB_K133 = 3 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 LWCB_MIN = NB_K133*KEEP(133)*NBRHS 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 IF (KEEP(201).EQ.0) THEN IF (ITMP8.NE.KEEP8(24)) THEN INFO(1) = -41 INFO(2) = id%LWK_USER GOTO 99 ENDIF ELSE KEEP8(24)=ITMP8 ENDIF MAXS = 0_8 IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_731(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ELSE IF (associated(id%S)) THEN MAXS = KEEP8(23) ELSE IF (KEEP(201).EQ.0) THEN WRITE(*,*) ' Working array S not allocated ', & ' on entry to solve phase (in core) ' CALL MUMPS_ABORT() ELSE IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ENDIF ALLOCATE (id%S(MAXS), stat = allocok) KEEP8(23)=MAXS IF ( allocok .GT. 0 ) THEN WRITE(*,*) ' Problem allocation of S at solve' INFO(1) = -13 CALL MUMPS_731(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) ENDIF ENDIF IF(KEEP(201).EQ.0)THEN LA = KEEP8(31) ELSE LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF IF ( MAXS-LA .GT. int(LWCB_MIN,8) ) THEN TMP_LWCB8 = min( MAXS - LA, int(huge(LWCB),8) ) LWCB = int( TMP_LWCB8, kind(LWCB) ) WORK_WCB => id%S(LA+1_8:LA+TMP_LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB = LWCB_MIN ALLOCATE(WORK_WCB(LWCB_MIN), stat = allocok) IF (allocok < 0 ) THEN INFO(1)=-13 INFO(2)=LWCB_MIN ENDIF WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(size(WORK_WCB),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF 99 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL DMUMPS_590(LA) CALL DMUMPS_586(id) IS_INIT_OOC_DONE = .TRUE. ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF (id%MYID .eq. MASTER) THEN IF ( (KEEP(242).NE.0) .or. (KEEP(243).NE.0) ) THEN IF ( (KEEP(237) .EQ.0) .and. (KEEP(111).EQ.0) ) THEN KEEP(242) = 0 KEEP(243) = 0 ENDIF ENDIF 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 WRITE (MPG, 153) KEEP(252) ENDIF ENDIF LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ERANAL = ((ICNTL(11) .GT. 0) .OR. (ICNTL(10) .GT. 0)) IF ( (KEEP(55).eq.0) .AND. KEEP(54).eq.0 .AND. & .NOT.associated(id%A) ) THEN ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. ELSE ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) ENDIF IF ((KEEP(111).NE.0).OR.(KEEP(237).NE.0).OR. & (KEEP(252).NE.0) ) THEN IF (ICNTL10 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF (ICNTL11 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. END IF IF (KEEP(221).NE.0) THEN IF (ICNTL10 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 (reduced RHS))' ENDIF IF (ICNTL11 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 (reduced RHS)' ENDIF ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. END IF IF ((ERANAL .AND. NBRHS > 1) .OR. ICNTL(21) > 0) THEN IF (ICNTL11 > 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to zero' ICNTL11=0 ENDIF IF (ICNTL10 > 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to zero' ICNTL10=0 ENDIF ERANAL = .FALSE. ENDIF IF (ERANAL) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN WRITE(*,*) ' 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 IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 END IF 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(ERANAL,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) CALL MPI_BCAST(KEEP(242),1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(243),1,MPI_INTEGER,MASTER, & id%COMM,IERR) DO_PERMUTE_RHS = (KEEP(242).NE.0) IF ( KEEP(242).NE.0) THEN IF ((KEEP(237).EQ.0).AND.(KEEP(111).EQ.0)) THEN IF (MP.GT.0) THEN write(MP,*) ' Warning incompatible options ', & ' permute RHS reset to false ' ENDIF DO_PERMUTE_RHS = .FALSE. ENDIF ENDIF IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN 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 #if defined(check) IF ( id%MYID_NODES .EQ. MASTER ) THEN WRITE(*,*) " ES A-1 DO_Perm Interleave =" WRITE(*,144) id%KEEP(235), id%KEEP(237), & id%KEEP(242),id%KEEP(243) ENDIF #endif MSG_MAX_BYTES_SOLVE = ( 4 + KEEP(133) ) * KEEP(34) + & KEEP(133) * NBRHS * KEEP(35) & + 16 * KEEP(34) IF (KEEP(237).EQ.0) THEN 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 MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(35) ) ENDIF 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 (LP.GT.0) & 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 ) THEN DMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL DMUMPS_55( DMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = DMUMPS_LBUF_INT IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF DMUMPS_LBUF = (MSG_MAX_BYTES_SOLVE + 2*KEEP(34) )*id%NSLAVES DMUMPS_LBUF = min(DMUMPS_LBUF, 100 000 000) DMUMPS_LBUF = max(DMUMPS_LBUF, & (MSG_MAX_BYTES_SOLVE+2*KEEP(34)) * min(id%NSLAVES,3)) DMUMPS_LBUF = DMUMPS_LBUF + KEEP(34) CALL DMUMPS_53( DMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = DMUMPS_LBUF/KEEP(34) + 1 IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF ENDIF IF ( & ( id%MYID .NE. MASTER ) & .or. & ( 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. & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) & ) THEN ALLOCATE(RHS_MUMPS(id%N*NBRHS),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_MUMPS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N*NBRHS IF (LP > 0) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' GOTO 111 END IF ELSE RHS_MUMPS=>id%RHS ENDIF IF ( I_AM_SLAVE ) THEN LD_RHSCOMP = max(KEEP(89),1) IF (id%MYID.EQ.MASTER) THEN LD_RHSCOMP = max(LD_RHSCOMP, KEEP(247)) ENDIF IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN IF (.NOT.associated(id%RHSCOMP)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF IF (.NOT.associated(id%POSINRHSCOMP)) THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF LENRHSCOMP = size(id%RHSCOMP) LD_RHSCOMP = LENRHSCOMP/id%NRHS ELSE IF (KEEP(221).EQ.1) THEN IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) ENDIF LENRHSCOMP = LD_RHSCOMP*id%NRHS ALLOCATE (id%RHSCOMP(LENRHSCOMP)) NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) ENDIF ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE LENRHSCOMP = LD_RHSCOMP*NBRHS IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) ENDIF ALLOCATE (id%RHSCOMP(LENRHSCOMP)) NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) ENDIF ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF LIWK_SOLVE = 4 * KEEP(28) + 1 IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE( LIWK_SOLVE), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 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) LIW = KEEP(32) 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) IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) ) THEN ALLOCATE(POSINRHSCOMP_N(id%N), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP.GT.0) WRITE(LP,*) & ' ERROR in DMUMPS_301: allocating POSINRHSCOMP_N' INFO(1) = -13 INFO(2) = id%N GOTO 111 END IF NB_BYTES = NB_BYTES + int(size(POSINRHSCOMP_N),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) END IF ELSE LIW=0 END IF 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) & ) & .OR. ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) & ) 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 DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF 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 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif CALL MUMPS_276( 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 CALL MPI_BCAST(UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN 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 (LP > 0) 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 (LP > 0) 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 LIW_PASSED=max(1,LIW) IF (KEEP(89) .GT. 0) THEN CALL DMUMPS_535( 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 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 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 40 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 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 IF ( ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) THEN 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 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 IF ( id%MYID .EQ. MASTER ) THEN 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 CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF ENDIF ENDIF IF ( KEEP(248)==1 ) THEN JEND_RHS = 0 IF (DO_PERMUTE_RHS) THEN 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 STRAT_PERMAM1 = KEEP(242) CALL MUMPS_780 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF 109 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (id%NSLAVES .EQ. 1) THEN IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF 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 IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_772 & (PERM_RHS, id%NRHS, id%N, id%KEEP(28), & id%PROCNODE_STEPS(1), id%STEP(1), id%NSLAVES, & id%Step2node(1), & IERR) ENDIF ENDIF ENDIF ENDIF IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) 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 ( & ( id%MYID .NE. MASTER ) & .or. & ( 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. & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) & ) THEN LD_RHS = id%N IBEG = 1 ELSE IF ( associated(id%RHS) ) THEN LD_RHS = max(id%LRHS, id%N) ELSE LD_RHS = id%N ENDIF IBEG = (BEG_RHS-1) * LD_RHS + 1 ENDIF JBEG_RHS = BEG_RHS IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 ) THEN JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN DO I=1, id%N RHS_MUMPS((PERM_RHS(JBEG_RHS) -1)*LD_RHS+I) & = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 CYCLE 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 DO I=1, id%N RHS_MUMPS((JBEG_RHS -1)*LD_RHS + I) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN IBEG = (JBEG_RHS-1) * LD_RHS + 1 ENDIF ENDIF CALL MPI_BCAST( JBEG_RHS,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0) THEN IBEG_REDRHS= (JBEG_RHS-1)*LD_REDRHS + 1 ELSE IBEG_REDRHS=-142424 ENDIF IF ( I_AM_SLAVE ) THEN IF ( KEEP(221).EQ.0 ) THEN IBEG_RHSCOMP= 1 ELSE IBEG_RHSCOMP= (JBEG_RHS-1)*LD_RHSCOMP + 1 ENDIF ELSE IBEG_RHSCOMP=-152525 ENDIF #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN IF (KEEP(248)==1) THEN NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 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 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)) & STOP_AT_NEXT_EMPTY_COL =.TRUE. IF (COLSIZE.GT.0) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN NBCOL_INBLOC = NBCOL_INBLOC -1 NBRHS_EFF = NBCOL EXIT ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NBCOL.NE.NBRHS_EFF) THEN WRITE(6,*) 'INTERNAL ERROR 1 in DMUMPS_301 ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF 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) JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 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 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 IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN 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 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) 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 & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN 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 & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY & => 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 RHS_SPARSE_COPY = ONE ELSE IF (.NOT. LSCAL) 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)) 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 ENDIF IF (KEEP(23) .NE. 0) THEN IF (MTYPE .NE. 1) THEN IF (KEEP(248)==0) THEN ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in DMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF DO K = 1, NBRHS_EFF KDEC = IBEG+(K-1)*LD_RHS DO I = 1, id%N C_RW2(I)=RHS_MUMPS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) RHS_MUMPS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ELSE IPOS = 1 DO I=1, NBCOL_INBLOC 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 ENDIF ENDIF IF (ERANAL) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+(K-1)*LD_RHS DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = RHS_MUMPS(KDEC+I-1) END DO ENDDO ENDIF ENDIF IF (LSCAL) THEN IF (KEEP(248)==0) THEN IF (MTYPE .EQ. 1) THEN DO K =1, NBRHS_EFF KDEC = (K-1) * LD_RHS + IBEG - 1 DO I = 1, id%N RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * & id%ROWSCA(I) END DO ENDDO ELSE DO K =1, NBRHS_EFF KDEC = (K-1) * LD_RHS + IBEG - 1 DO I = 1, id%N RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * & id%COLSCA(I) END DO ENDDO ENDIF ELSE KDEC=id%IRHS_PTR(JBEG_RHS) IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN RHS_SPARSE_COPY(IPOS) = id%ROWSCA(PERM_RHS(I)) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE DO K = 1, COLSIZE II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) 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 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 END IF ENDIF #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif 30 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF ( I_AM_SLAVE ) THEN IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) .OR. & (KEEP(252).NE.0) ) THEN IF (BUILD_POSINRHSCOMP) THEN IF (KEEP(111).NE.0) THEN WHAT = 2 MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN WHAT = 0 MTYPE_LOC = 1 ELSE WHAT = 1 MTYPE_LOC = MTYPE ENDIF LIW_PASSED=max(1,LIW) IF (WHAT.EQ.0) THEN CALL DMUMPS_639(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(1), IDUMMY, 1, MTYPE_LOC, & WHAT ) ELSE CALL DMUMPS_639(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(1), POSINRHSCOMP_N(1), & id%N, MTYPE_LOC, & WHAT ) ENDIF BUILD_POSINRHSCOMP = .FALSE. ENDIF ENDIF ENDIF 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(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN 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 #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0)) THEN IF (KEEP(248) == 0) THEN IF ( .NOT.I_AM_SLAVE ) THEN CALL DMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) BUILD_POSINRHSCOMP=.FALSE. ELSE LIW_PASSED = max( LIW, 1 ) CALL DMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), & BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) BUILD_POSINRHSCOMP=.FALSE. ENDIF IF (INFO(1).LT.0) GOTO 90 ELSE CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER) 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. 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) 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 45 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_DOUBLE_PRECISION, & 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 IF ( I_AM_SLAVE ) THEN IF (KEEP(237).NE.0) THEN K=1 RHS_MUMPS(1:NBRHS_EFF*LD_RHS) = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IF (POSINRHSCOMP_N(J).NE.0) THEN RHS_MUMPS((K-1) * LD_RHS + J) = & RHS_SPARSE_COPY(IPOS) ENDIF K = K + 1 IPOS = IPOS + COLSIZE ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'INTERNAL ERROR 2 in DMUMPS_301 ', & K, NBRHS_EFF call MUMPS_ABORT() ENDIF ELSE IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0)) THEN 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 DO K = 1, NBCOL_INBLOC KDEC = (K-1) * LD_RHS + IBEG - 1 RHS_MUMPS(KDEC+1:KDEC+id%N) = ZERO DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IF (POSINRHSCOMP_N(I).NE.0) THEN RHS_MUMPS(KDEC+I)= RHS_SPARSE_COPY(IZ) ENDIF ENDDO ENDDO END IF ENDIF ENDIF ELSE IF (I_AM_SLAVE) THEN IF (KEEP(111).NE.0) THEN 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 IEND_GLOB_DEF = id%KEEP(112) id%KEEP(235) = 1 DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN 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+K35_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN 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 50 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 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) RHS_MUMPS( IBEG : & (IBEG + (NBRHS_EFF)*LD_RHS -1) ) = ZERO ENDIF DO K=1, NBRHS_EFF KDEC = (K-1) *LD_RHSCOMP id%RHSCOMP(KDEC+1:KDEC+LD_RHSCOMP)=ZERO END DO IF ((KEEP(235).NE.0).AND. INTERLEAVE_PAR) THEN DO I=IBEG_GLOB_DEF,IEND_GLOB_DEF IF (id%MYID_NODES .EQ. MAP_PIVNUL_LIST(I) ) THEN JJ= POSINRHSCOMP_N(PERM_PIV_LIST(I)) IF (JJ.GT.LD_RHSCOMP) THEN WRITE(6,*) ' Internal ERROR JJ, LD_RHSCOMP=', & JJ, LD_RHSCOMP ENDIF IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN id%RHSCOMP(IBEG_RHSCOMP -1+ & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = & abs(id%DKEEP(2)) ELSE id%RHSCOMP(IBEG_RHSCOMP -1+ & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = ONE ENDIF ENDIF ENDIF ENDDO ELSE DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) JJ= POSINRHSCOMP_N(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP & + JJ) = id%DKEEP(2) ELSE id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP & + JJ) = ONE ENDIF ENDIF ENDDO ENDIF IF ( KEEP(17).NE.0 .and. id%MYID_NODES.EQ.MASTER_ROOT) THEN IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -90999 ENDIF ELSE ENDIF ENDIF IF ( I_AM_SLAVE ) THEN LWCB_SOL_C = LWCB IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN IF ( associated(id%root%RHS_CNTR_MASTER_ROOT) ) THEN PTR_RHS_ROOT => id%root%RHS_CNTR_MASTER_ROOT LPTR_RHS_ROOT = size(id%root%RHS_CNTR_MASTER_ROOT) ELSE LPTR_RHS_ROOT = NBRHS_EFF * SIZE_ROOT IPT_RHS_ROOT = LWCB - LPTR_RHS_ROOT + 1 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1 IPT_RHS_ROOT = LWCB PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT ENDIF ENDIF IF (KEEP(221) .EQ. 2 ) THEN IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE IF ( id%MYID .EQ. MASTER) THEN IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 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 II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 ENDIF ENDIF IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF ((id%KEEP(235).EQ.0).and.(id%KEEP(237).EQ.0) ) THEN PRUNED_SIZE_LOADED = 0_8 CALL DMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, & IWCB, LIWCB, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%NA(1),id%LNA,id%NE_STEPS(1), SRW3, MTYPE, & ICNTL(1), 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, id%PROCNODE_STEPS(1), & id%NSLAVES, INFO(1), KEEP(1), KEEP8(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(1), BUILD_POSINRHSCOMP & , 1 , 1 , 1 & , 1 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & ) ELSE IF ((KEEP(235).NE.0).AND.KEEP(221).NE.2.AND. & KEEP(111).EQ.0) THEN DO K=1, NBRHS_EFF DO I=1, LD_RHSCOMP id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO ENDDO ENDDO ELSEIF (KEEP(237).NE.0) THEN DO K=1, NBRHS_EFF DO I=1, LD_RHSCOMP id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO ENDDO ENDDO ENDIF IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF CALL DMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, id%NA(1),id%LNA, & id%NE_STEPS(1), SRW3, MTYPE, ICNTL(1), 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, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1),KEEP(1),KEEP8(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(1), BUILD_POSINRHSCOMP, & NZ_THIS_BLOCK, NBCOL_INBLOC, id%NRHS, & JBEG_RHS , id%Step2node(1), id%KEEP(28), IRHS_SPARSE_COPY(1), & IRHS_PTR_COPY(1), & size(PERM_RHS), PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV & ) ENDIF END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LP.GT.0) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LP.GT.0) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF IF (INFO(1).LT.0) GO TO 90 IF ( KEEP(221) .EQ. 1 ) THEN IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE IF ( id%MYID .EQ. MASTER ) THEN IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 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 II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 ENDIF ENDIF IF ( KEEP(221) .NE. 1 ) THEN IF (ICNTL21 == 0) THEN IF ((.NOT. I_AM_SLAVE).AND.KEEP(237).EQ.0) THEN ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) IF (allocok > 0) THEN ALLOCATE( CWORK(KEEP(247)), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=KEEP(247) ENDIF ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) 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 ( .NOT.I_AM_SLAVE ) THEN IF (KEEP(237).EQ.0) THEN CALL DMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & 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) & ) DEALLOCATE( CWORK ) ELSE CALL DMUMPS_812(id%NSLAVES,id%N, & id%MYID, id%COMM, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) & ,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 & ) ENDIF ELSE IF (KEEP(237).EQ.0) THEN CALL DMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & 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, & id%RHSCOMP(1), LENRHSCOMP, & LSCAL, PT_SCALING(1), size(PT_SCALING) & ) ELSE CALL DMUMPS_812(id%NSLAVES,id%N, & id%MYID, id%COMM, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) & , 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), POSINRHSCOMP_N, & id%N & ) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN 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 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 1 gather sol_driver" CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ELSE 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 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 2 gather sol_driver" CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ENDIF ENDIF ELSE IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) IF ( KEEP(89) .GT. 0 ) THEN CALL DMUMPS_532(id%NSLAVES, & id%N, id%MYID_NODES, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%ISOL_loc(1), & id%SOL_loc(1), 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 ) ENDIF ENDIF ENDIF ENDIF IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN DO I = 1, ICNTL10 write(*,*) 'FIXME: to be implemented' END DO END IF IF (ERANAL) THEN IF ((ICNTL10 .GT. 0) .AND. (ICNTL11 .GT. 0)) THEN IF (id%MYID .EQ. MASTER) THEN GIVSOL = .FALSE. IF (MP .GT. 0) WRITE( MP, 170 ) ALLOCATE(R_RW1(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 776 ENDIF ALLOCATE(C_RW2(id%N),stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 776 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) END IF 776 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL DMUMPS_278( ICNTL(9), id%N, id%NZ, id%A(1), & id%IRN(1), id%JCN(1), & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, & KEEP(1),KEEP8(1) ) ELSE CALL DMUMPS_121( ICNTL(9), id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, & KEEP(1),KEEP8(1) ) ENDIF END IF ELSE CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) ALLOCATE( C_LOCWK54( id%N ), stat =allocok ) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N endif CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL DMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_RW2, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) C_RW2 = SAVERHS - C_RW2 ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF NB_BYTES = NB_BYTES - int(size(C_LOCWK54),8)*K35_8 DEALLOCATE( C_LOCWK54 ) ALLOCATE( R_LOCWK54( id%N ), stat =allocok ) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N endif CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NZ_loc .NE. 0 ) THEN CALL DMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1)) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_RW1, & 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 NB_BYTES = NB_BYTES - int(size(R_LOCWK54),8)*K16_8 DEALLOCATE( R_LOCWK54 ) END IF IF ( id%MYID .EQ. MASTER ) THEN CALL DMUMPS_205(ICNTL(9),INFO(1),id%N,id%NZ, & RHS_MUMPS(IBEG), SAVERHS,R_RW1,C_RW2,GIVSOL, & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MP,ICNTL(1), & KEEP(1),KEEP8(1)) NB_BYTES = NB_BYTES - int(size(R_RW1),8)*K16_8 & - int(size(C_RW2),8)*K35_8 DEALLOCATE(R_RW1) DEALLOCATE(C_RW2) END IF END IF IF ( PROK .AND. ICNTL10 .GT. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .GT. 0 ) WRITE( MPG, 270 ) 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( 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 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 NITREF = ICNTL10 JOBIREF= ICNTL11 IF ( PROKG .AND. ICNTL10 .GT. 0 ) & WRITE( MPG, 240) 'MAXIMUM NUMBER OF STEPS =', NITREF DO I = 1, id%N D( I ) = RONE END DO 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 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 22 CONTINUE IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .eq. 0 ) THEN IF (KEEP(55).NE.0) THEN CALL DMUMPS_119(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE IF ( MTYPE .eq. 1 ) THEN CALL DMUMPS_207 & ( id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) ELSE CALL DMUMPS_207 & ( id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) END IF ENDIF ENDIF END IF ELSE IF ( KASE .eq. 0 ) THEN IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL DMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE CALL DMUMPS_207(id%A_loc(1), & id%NZ_loc, 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 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 END IF END IF IF ( id%MYID .eq. MASTER ) THEN ARRET = CNTL(2) IF (ARRET .LT. 0.0D0) THEN ARRET = sqrt(epsilon(0.0D0)) END IF CALL DMUMPS_206(id%NZ,id%N,SAVERHS,RHS_MUMPS(IBEG), & C_Y, D, R_W, C_W, & IW1, KASE,RINFOG(7), & RINFOG(9), JOBIREF, RINFOG(10), NITREF, NOITER, MP, & KEEP(1),KEEP8(1), ARRET ) END IF IF ( KEEP(54) .ne. 0 ) THEN CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) END IF IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .eq. 14 ) THEN IF (KEEP(55).NE.0) THEN CALL DMUMPS_122( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%NA_ELT, id%A_ELT(1), & SAVERHS, RHS_MUMPS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL DMUMPS_208 & (id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), SAVERHS, & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL DMUMPS_208 & (id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), SAVERHS, & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) END IF ENDIF GOTO 22 END IF END IF ELSE IF ( KASE.eq.14 ) THEN CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL DMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(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 IF ( I_AM_SLAVE .and. id%NZ_loc .NE. 0 ) THEN CALL DMUMPS_193( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(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) END IF GOTO 22 END IF END IF IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .GT. 0 ) THEN IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF END IF END IF CALL MPI_BCAST( KASE , 1, MPI_INTEGER, MASTER, & id%COMM, IERR) CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) IF ( KASE .GT. 0 ) THEN BUILD_POSINRHSCOMP=.FALSE. IF ( .NOT.I_AM_SLAVE ) THEN CALL DMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, C_Y(1), id%N, 1, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) ELSE LIW_PASSED = max( LIW, 1 ) CALL DMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, C_Y(1), id%N, 1, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), & BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) CALL DMUMPS_245( id%root, id%N, id%S(1), LA_PASSED, & id%IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, C_Y, & id%N, NBRHS_EFF, id%NA(1), id%LNA, id%NE_STEPS(1), SRW3, SOLVET, & ICNTL(1), 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, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(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(1), BUILD_POSINRHSCOMP & , 1 , 1 , 1 & , 1 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & ) END IF IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 IF ( .NOT. I_AM_SLAVE .AND. INFO(1) .GE. 0) THEN ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) IF (allocok > 0) THEN ALLOCATE( CWORK(KEEP(247)), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=KEEP(247) ENDIF ENDIF ENDIF 89 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GO TO 90 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 ) IF ( .NOT. I_AM_SLAVE ) THEN CALL DMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & SOLVET, C_Y, id%N, NBRHS_EFF, & 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, size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING)) DEALLOCATE( CWORK ) ELSE CALL DMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & SOLVET, C_Y, id%N, NBRHS_EFF, & 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, & id%RHSCOMP(1), LENRHSCOMP, & LSCAL, PT_SCALING(1), size(PT_SCALING)) ENDIF GO TO 22 ELSEIF ( KASE .LT. 0 ) THEN INFO( 1 ) = INFO( 1 ) + 8 END IF IF ( id%MYID .eq. MASTER ) THEN NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(D ),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W,D) DEALLOCATE(IW1) ENDIF IF ( PROKG ) THEN IF (NITREF.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, 141 ) 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS &=', NOITER ENDIF ENDIF IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF END IF IF ( PROK .AND. ICNTL10 .GT.0 ) WRITE( MP, 131 ) IF (ICNTL11 .GT. 0) THEN IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL DMUMPS_278( MTYPE, id%N, id%NZ, id%A(1), & id%IRN(1), id%JCN(1), & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) ELSE CALL DMUMPS_121( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) ENDIF END IF ELSE CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL DMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_W, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) C_W = SAVERHS - C_W ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL DMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_Y, & 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 END IF IF (id%MYID .EQ. MASTER) THEN IF ((MPG .GT. 0) .AND. (NITREF .GT. 0)) WRITE( MPG, 65 ) IF ((MPG .GT. 0) .AND. (NITREF .LE. 0)) WRITE( MPG, 170 ) GIVSOL = .FALSE. CALL DMUMPS_205(MTYPE,INFO(1),id%N,id%NZ,RHS_MUMPS(IBEG), & SAVERHS,R_Y,C_W,GIVSOL, & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) &'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', RINFOG(7) WRITE( MPG, 115 ) &'------(8):---------------------------- (W2)=', RINFOG(8) 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 IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) 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) END IF IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0 .AND. KEEP(237).EQ.0 ) THEN IF ((KEEP(221).NE.1 .AND. ICNTL(9) .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN ALLOCATE( C_RW1( id%N ),stat =allocok ) 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 KDEC = (K-1)*LD_RHS+IBEG-1 DO 70 I = 1, id%N C_RW1(I) = RHS_MUMPS(KDEC+I) 70 CONTINUE DO 80 I = 1, id%N JPERM = id%UNS_PERM(I) RHS_MUMPS( KDEC+JPERM ) = C_RW1( I ) 80 CONTINUE END DO DEALLOCATE( C_RW1 ) END IF END IF IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1 & .and. KEEP(237).EQ.0 ) THEN 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) & (RHS_MUMPS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN BEG_RHS = BEG_RHS + NBRHS_EFF ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF ENDDO IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) & .AND. ( KEEP(237).EQ.0 ) & .AND. ( ICNTL21.EQ.0 ) & .AND. ( KEEP(221) .NE.1 ) & .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 RHS_MUMPS((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 RHS_MUMPS((JBEG_NEW -1)*LD_RHS + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF 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 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 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 JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,LD_RHSCOMP id%RHSCOMP((JBEG_NEW -1)*LD_RHSCOMP + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF id%INFO(26) = int(NB_BYTES_MAX / 1000000_8, 4) CALL MUMPS_243( 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 90 CONTINUE IF (INFO(1) .LT.0 ) THEN ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL DMUMPS_582(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF 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 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(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF CALL DMUMPS_57( IERR ) CALL DMUMPS_59( IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF IF ( & ( & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & .and. ICNTL21.ne.0 ) & .or. & ( KEEP(237).NE.0 ) & ) & THEN IF ( I_AM_SLAVE ) THEN IF (associated(RHS_MUMPS) ) THEN NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 DEALLOCATE(RHS_MUMPS) ENDIF ENDIF ENDIF NULLIFY(RHS_MUMPS) ELSE IF (associated(RHS_MUMPS)) THEN NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) END IF END IF IF (I_AM_SLAVE) THEN IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K35_8 DEALLOCATE(SRW3) ENDIF IF (allocated(POSINRHSCOMP_N)) THEN NB_BYTES = NB_BYTES - int(size(POSINRHSCOMP_N),8)*K34_8 DEALLOCATE(POSINRHSCOMP_N) ENDIF IF (LSCAL .AND. ICNTL21==1) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (associated(id%S).AND.KEEP(201).GT.0) THEN 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 IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) ENDIF IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) NULLIFY(id%POSINRHSCOMP) ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K35_8 DEALLOCATE( WORK_WCB ) ENDIF NULLIFY( WORK_WCB ) ENDIF RETURN 65 FORMAT (//' ERROR ANALYSIS AFTER ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' VECTOR SOLUTION FOR COLUMN ',I12) 115 FORMAT(1X, A44,1P,D9.2) 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, A42,I4) END SUBROUTINE DMUMPS_301 SUBROUTINE DMUMPS_245(root, N, A, LA, IW, LIW, W, LWC, & IWCB,LIWW,RHS,LRHS,NRHS,NA,LNA,NE_STEPS, W2, & MTYPE, ICNTL, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1,LIW1, & PROCNODE_STEPS, SLAVEF, & INFO, KEEP,KEEP8, 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, BUILD_POSINRHSCOMP & , 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 & ) 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 LWC,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 LRHS, NRHS, LRHSCOMP DOUBLE PRECISION A(LA), W(LWC), RHS(LRHS,NRHS), & W2(KEEP(133)), & RHSCOMP(LRHSCOMP,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP(KEEP(28)) 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 LPTR_RHS_ROOT DOUBLE PRECISION PTR_RHS_ROOT(LPTR_RHS_ROOT) LOGICAL BUILD_POSINRHSCOMP INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,LPANEL_POS INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB,PTRACB INTEGER MTYPE_LOC 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' EXTERNAL DMUMPS_248, DMUMPS_249 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) 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 INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_808 EXTERNAL :: MUMPS_808 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 NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) PTRACB = PTRICB + KEEP(28) IPOOL = PTRACB + 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 in DMUMPS_245", & 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 ( 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_276(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_276(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_276(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 #if defined(NOT_USED) IF ( KEEP(201).GT.0) THEN CALL DMUMPS_789(KEEP(28), & KEEP(38), KEEP(20) ) ENDIF #endif nb_nodes_RHS = 0 #if defined(check) WRITE(*,*) "NBCOL_INBLOC=",NBCOL_INBLOC WRITE(*,*) "JBEG SIZE=",JBEG_RHS, SIZE(IRHS_PTR) #endif 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_276(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_797( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_797( & .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_809(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_808 & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_802( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) 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_583(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_248(N, A(1), LA, IW(1), LIW, W(1), & LWC, RHS, LRHS, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, & NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP,KEEP8, & 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 & ) 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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(I.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_248(N, A(1), LA, IW(1), LIW, W(1), & LWC, RHS, LRHS, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, & Pruned_SONS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP,KEEP8, & 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 & ) DEALLOCATE(prun_NA) ENDIF BUILD_POSINRHSCOMP = .FALSE. #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM DMUMPS_248,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) 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)) 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 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_798( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_798( & .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_809(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_808 & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_803( & 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_584(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_276(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 ( ( 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 write(6,*) " CPA to be double checked " 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_643( & 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_643', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL DMUMPS_286( 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)) IF(KEEP(201).GT.0)THEN CALL DMUMPS_598(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after DMUMPS_598 ', & 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 defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(111).NE.0) & I_WORKED_ON_ROOT = .FALSE. 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_797( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_797( & .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_809(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_808 & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_802( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL DMUMPS_584(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.SPECIAL_ROOT_REACHED ) THEN PTR_RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO 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_249( N, A, LA, IW, LIW, W(1), LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, & W2, NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, & 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) 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_249( N, A, LA, IW, LIW, W(1), LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, & W2, NE_STEPS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, & 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) ENDIF #if defined(V_T) CALL VTEND(back_soln,ierr) #endif ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N WRITE (MP,99992) IF (N.GT.0) WRITE (MP,99993) (RHS(I,1),I=1,K) IF (N.GT.0.and.NRHS>1) & WRITE (MP,99994) (RHS(I,2),I=1,K) 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_245 SUBROUTINE DMUMPS_521(NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NRHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, & LSCAL, SCALING, LSCALING) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, LCWORK DOUBLE PRECISION RHS (LRHS, NRHS) 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) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER STATUS(MPI_STATUS_SIZE), IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER SK38, SK20 INTEGER, PARAMETER :: FIN = -1 INTEGER, PARAMETER :: yes = 1 INTEGER, PARAMETER :: no = 0 INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist(:) INTEGER :: ONE_PACK INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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 DO J=1, NRHS DO I=1,N RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDDO ENDIF RETURN ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.0) THEN DO J=1, NRHS IF ( I_AM_SLAVE ) THEN CALL MPI_SEND(RHS(1, J), N, MPI_DOUBLE_PRECISION, MASTER, & GatherSol, COMM, IERR) & ELSE CALL MPI_RECV(RHS(1, J), N, MPI_DOUBLE_PRECISION, & 1, & GatherSol, COMM, STATUS, IERR ) IF (LSCAL) THEN DO I=1,N RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDIF ENDIF ENDDO RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .GE. MAXSurf) THEN ONE_PACK = yes ELSE IF (LCWORK .GE. MAXNPIV_estim) THEN ONE_PACK = no ELSE WRITE(*,*) & "Internal error 2 in DMUMPS_521:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (ONE_PACK .EQ. no .AND. I_AM_SLAVE) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_521:", & TYPE_PARAL, LCWORK, KEEP(246),KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (TYPE_PARAL .EQ. 0) &CALL MPI_BCAST(ONE_PACK, 1, MPI_INTEGER, & MASTER, COMM, IERR) 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_521 ' 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_275(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.AND.LSCAL) & CALL DMUMPS_522 ( ONE_PACK, .TRUE. ) ELSE IF (NPIV.GT.0) & CALL DMUMPS_522 ( ONE_PACK, .FALSE.) ENDIF ENDIF ENDDO CALL DMUMPS_523() 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 (ONE_PACK.EQ.yes) THEN CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV*NRHS, MPI_DOUBLE_PRECISION, & COMM, IERR) IF (LSCAL) THEN DO J=1, NRHS DO I=1,NPIV RHS(IROWlist(I),J)= & CWORK(I+(J-1)*NPIV)*SCALING(IROWlist(I)) ENDDO END DO ELSE DO J=1, NRHS DO I=1,NPIV RHS(IROWlist(I),J)= CWORK(I+(J-1)*NPIV) ENDDO END DO ENDIF ELSE DO J=1,NRHS 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),J)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE DO I=1,NPIV RHS(IROWlist(I),J)=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_522 ( ONE_PACK, SCALE_ONLY ) INTEGER, intent(in) :: ONE_PACK LOGICAL, intent(in) :: SCALE_ONLY INTEGER III IF (SCALE_ONLY) THEN DO II=1,NPIV I=IW(J1+II-1) DO J=1, NRHS RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDDO RETURN ENDIF DO II=1,NPIV I=IW(J1+II-1) DO J=1, NRHS CWORK(II+(J-1)*NPIV) = RHS(I,J) ENDDO ENDDO 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 ) IF (ONE_PACK.EQ.yes) THEN CALL MPI_PACK(CWORK(1), NPIV*NRHS, MPI_DOUBLE_PRECISION, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ELSE III = 1 DO J=1,NRHS CALL MPI_PACK(CWORK(III), NPIV, MPI_DOUBLE_PRECISION, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) III =III+NPIV ENDDO ENDIF N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL DMUMPS_523() END IF RETURN END SUBROUTINE DMUMPS_522 SUBROUTINE DMUMPS_523() 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_523 END SUBROUTINE DMUMPS_521 SUBROUTINE DMUMPS_812(NSLAVES, N, MYID, COMM, & RHS, LRHS, NRHS, 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_N, LPOS_N ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHS, LPOS_N DOUBLE PRECISION RHS (LRHS, NRHS) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSCOMP_N(LPOS_N) 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 INTEGER STATUS(MPI_STATUS_SIZE), 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) IF (POSINRHSCOMP_N(I).NE.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHS(I,K)*SCALING(I) ELSE RHS_SPARSE_COPY(IZ)=RHS(I,K) ENDIF ENDIF ENDDO K = K + 1 ENDDO RETURN ENDIF IF (I_AM_SLAVE) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IF (POSINRHSCOMP_N(I).NE.0) THEN RHS_SPARSE_COPY(IZ)=RHS(I,K) ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_DOUBLE_PRECISION, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in DMUMPS_812 ' 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) IF (POSINRHSCOMP_N(II).NE.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 IF (LSCAL) & CALL DMUMPS_813 ( .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_813 ( .FALSE. ) ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL DMUMPS_814() 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_813 ( 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_814() END IF RETURN END SUBROUTINE DMUMPS_813 SUBROUTINE DMUMPS_814() 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_814 END SUBROUTINE DMUMPS_812 SUBROUTINE DMUMPS_535(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_275 EXTERNAL MUMPS_275 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_275( 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_535 SUBROUTINE DMUMPS_532( & SLAVEF, N, MYID_NODES, & MTYPE, RHS, LD_RHS, NRHS, & ISOL_LOC, SOL_LOC, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & scaling_data, LSCAL, NB_RHSSKIPPED) 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, NRHS, LD_RHS INTEGER LSOL_LOC, BEG_RHS, NB_RHSSKIPPED INTEGER ISOL_LOC(LSOL_LOC) DOUBLE PRECISION SOL_LOC( LSOL_LOC, BEG_RHS+NRHS+NB_RHSSKIPPED-1) DOUBLE PRECISION RHS( LD_RHS , NRHS) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER JJ, J1, ISTEP, K, JEMPTY, JEND INTEGER IPOS, LIELL, NPIV LOGICAL ROOT DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NRHS-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(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 DO JJ=J1,J1+NPIV-1 K=K+1 IF (NB_RHSSKIPPED.GT.0) & SOL_LOC(K, BEG_RHS:JEMPTY) = ZERO IF (LSCAL) THEN SOL_LOC(K,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(K)*RHS(IW(JJ),1:NRHS) ELSE SOL_LOC(K,JEMPTY+1:JEND) = & RHS(IW(JJ),1:NRHS) ENDIF ENDDO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_532 SUBROUTINE DMUMPS_638 & (NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NRHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP, LENPOSINRHSCOMP, & BUILD_POSINRHSCOMP, ICNTL, INFO) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, LENPOSINRHSCOMP INTEGER ICNTL(40), INFO(40) DOUBLE PRECISION RHS (LRHS, NRHS) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N), POSINRHSCOMP(LENPOSINRHSCOMP) LOGICAL BUILD_POSINRHSCOMP INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER I, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER STATUS(MPI_STATUS_SIZE), IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER SK38, SK20, IPOSINRHSCOMP INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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) ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_276(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) 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 ) RHS( BUF_INDX(I), K ) = ZERO 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 IF (I_AM_SLAVE) THEN IF (BUILD_POSINRHSCOMP) THEN IPOSINRHSCOMP = 1 POSINRHSCOMP = -9678 ENDIF IF (MYID.NE.MASTER) RHS = ZERO DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(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 (BUILD_POSINRHSCOMP) THEN POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF IF (MYID.NE.MASTER) THEN 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_640() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL DMUMPS_640() ENDIF DEALLOCATE (BUF_INDX, BUF_RHS) RETURN CONTAINS SUBROUTINE DMUMPS_640() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_PRECISION, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX(I) DO K = 1, NRHS RHS( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO BUF_EFFSIZE = 0 RETURN END SUBROUTINE DMUMPS_640 END SUBROUTINE DMUMPS_638 SUBROUTINE DMUMPS_639 & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP, POSINRHSCOMP_N, LPIRC_N, MTYPE, & WHAT ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID_NODES, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N), POSINRHSCOMP(KEEP(28)) INTEGER LPIRC_N, WHAT, MTYPE INTEGER POSINRHSCOMP_N(LPIRC_N) INTEGER ISTEP INTEGER NPIV INTEGER SK38, SK20, IPOS, LIELL INTEGER JJ, J1 INTEGER IPOSINRHSCOMP INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 IF (WHAT .NE. 0.AND. WHAT.NE.1.AND.WHAT.NE.2) THEN WRITE(*,*) "Internal error in DMUMPS_639" CALL MUMPS_ABORT() ENDIF 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 IPOSINRHSCOMP = 1 POSINRHSCOMP = -9678 IF (WHAT .NE. 0) THEN POSINRHSCOMP_N = 0 ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP IF (WHAT .NE. 0) 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)) ENDIF IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_N(IW(JJ)) = IPOSINRHSCOMP+JJ-J1 END DO ENDIF IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_639 SUBROUTINE DMUMPS_248(N, A, LA, IW, LIW, WCB, LWCB, & RHS, LRHS, NRHS, & PTRICB, IWCB, LIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, BUILD_POSINRHSCOMP, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, & NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, INFO, & KEEP,KEEP8, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE DMUMPS_OOC IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER N, LIW, LWCB, LPOOL, LIWCB, LNA INTEGER SLAVEF, MYLEAF, COMM, MYID INTEGER INFO( 40 ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER LRHS, NRHS DOUBLE PRECISION A( LA ), RHS( LRHS, NRHS ), WCB( LWCB ) INTEGER 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) ) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSCOMP(KEEP(28)), LRHSCOMP LOGICAL BUILD_POSINRHSCOMP DOUBLE PRECISION RHSCOMP( LRHSCOMP, NRHS ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGSOU, DUMMY(1) LOGICAL FLAG INTEGER NBFIN, MYROOT INTEGER POSIWCB,POSWCB,PLEFTWCB INTEGER INODE INTEGER RHSCOMPFREEPOS INTEGER I INTEGER III, NBROOT,LEAF LOGICAL BLOQ EXTERNAL MUMPS_275 INTEGER MUMPS_275 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1 IF (BUILD_POSINRHSCOMP) RHSCOMPFREEPOS= 1 DO I = 1, KEEP(28) NSTK_S(I) = NE_STEPS(I) ENDDO PTRICB = 0 CALL MUMPS_362(N, LEAF, NBROOT, MYROOT, MYID, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) NBFIN = SLAVEF IF ( MYROOT .EQ. 0 ) THEN NBFIN = NBFIN - 1 DUMMY(1) = 1 CALL DMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF) END IF MYLEAF = LEAF - 1 III = 1 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL DMUMPS_574 & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF BLOQ = ( ( III .EQ. LEAF ) & ) CALL DMUMPS_303( 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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL DMUMPS_574 & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE CALL DMUMPS_302( 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, RHS, LRHS, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & MYROOT, INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL DMUMPS_150( MYID,COMM,BUFR, & LBUFR,LBUFR_BYTES ) RETURN END SUBROUTINE DMUMPS_248 RECURSIVE SUBROUTINE DMUMPS_323 & ( 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, STEP, PROCNODE_STEPS, & RHS, LRHS & ) USE DMUMPS_OOC USE DMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8) :: LA INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) 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 ) INTEGER LRHS DOUBLE PRECISION RHS(LRHS, NRHS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, K, JJ INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PTRX, PTRY, PDEST, I INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG EXTERNAL MUMPS_275 INTEGER MUMPS_275 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, & LONG, 1, MPI_INTEGER, COMM, IERR ) 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 .LT. LONG * NRHS) THEN INFO( 1 ) = -11 INFO( 2 ) = PLEFTWCB - POSWCB - 1 + LONG * NRHS 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 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_DOUBLE_PRECISION, COMM, IERR ) DO I = 1, LONG RHS(IWCB(I),K) = RHS(IWCB(I),K) +WCB(PLEFTWCB+I-1) 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 ) PTRY = PLEFTWCB PTRX = PLEFTWCB + NCV * NRHS PLEFTWCB = PLEFTWCB + (NPIV + NCV) * NRHS IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 INFO(2) = -POSWCB + PLEFTWCB -1 GO TO 260 END IF DO K=1, NRHS 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 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_643( & 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 ( NRHS == 1 ) THEN CALL dgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE CALL dgemm( 'N', 'N', NCV, NRHS, NPIV, ALPHA, & A(APOS), NCV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) ENDIF ELSE IF ( NRHS == 1 ) THEN CALL dgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE CALL dgemm( 'T', 'N', NCV, NRHS, NPIV, ALPHA, & A(APOS), NPIV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) ENDIF ENDIF IF (KEEP(201).GT.0) THEN CALL DMUMPS_598(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 PDEST = MUMPS_275( 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 DO I = 1, NCV JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) DO K=1, NRHS RHS(JJ,K)= RHS(JJ,K) + WCB(PTRY+I-1+(K-1)*NCV) ENDDO END DO 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_78( NRHS, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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 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_44( MYID, SLAVEF, COMM ) 270 CONTINUE RETURN END SUBROUTINE DMUMPS_323 SUBROUTINE DMUMPS_302( 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, & RHS, LRHS, NRHS, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & MYROOT, & INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & & ) USE DMUMPS_OOC USE DMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MTYPE INTEGER INODE, LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIWCB, LWCB, LIW, POSWCB, PLEFTWCB, POSIWCB INTEGER(8) :: LA INTEGER N, LPOOL, III, LEAF, NBFIN INTEGER MYROOT INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER LRHS, NRHS DOUBLE PRECISION WCB( LWCB ), A( LA ) DOUBLE PRECISION RHS(LRHS, NRHS ), 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(KEEP(28)), LRHSCOMP, RHSCOMPFREEPOS DOUBLE PRECISION RHSCOMP(LRHSCOMP, NRHS) LOGICAL BUILD_POSINRHSCOMP EXTERNAL dgemv, dtrsv, dgemm, dtrsm, MUMPS_275 INTEGER MUMPS_275 DOUBLE PRECISION ALPHA,ONE,ZERO PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, & IERR, IFR_ini, & IFR, LIELL, JJ, & NELIM, PLEFT, PCB_COURANT, PPIV_COURANT INTEGER IPOSINRHSCOMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG, OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER POSWCB1,POSWCB2 INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, & JFIN, NBJ, NUPDATE_PANEL, & PPIV_PANEL, PCB_PANEL, NBK, TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB INTEGER LDAJ, 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 ) 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_643( & 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_755( & 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 IFR = 0 DO JJ = J1, J3 J = IW( JJ ) IFR = IFR + 1 DO K=1,NRHS RHS_ROOT(IFR+NPIV*(K-1)) = RHS(J,K) END DO END DO 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 DUMMY (1) = 1 CALL DMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF) 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_690( LDAJ_FIRST_PANEL ) ENDIF PLEFT = PLEFTWCB PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + LIELL * NRHS IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 INFO(2) = PLEFTWCB - POSWCB - 1 GO TO 260 END IF IF (KEEP(201).EQ.1) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV DO K=1, NRHS IFR = PPIV_COURANT + (K-1)*LIELL - 1 DO JJ = J1, J3 J = IW(JJ) IFR = IFR + 1 WCB(IFR) = RHS(J,K) ENDDO IF (NCB.GT.0) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR = IFR + 1 WCB(IFR) = RHS(J,K) RHS (J,K) = ZERO ENDDO ENDIF END DO ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV*NRHS IFR = PPIV_COURANT - 1 OMP_FLAG = NRHS.GT.4 IFR_ini = IFR DO 130 JJ = J1, J3 J = IW(JJ) IFR = IFR_ini + (JJ-J1) + 1 DO K=1, NRHS WCB(IFR+(K-1)*NPIV) = RHS(J,K) END DO 130 CONTINUE IFR = PCB_COURANT - 1 IF (NPIV .LT. LIELL) THEN IFR_ini = IFR DO 140 JJ = J3 + 1, J2 J = IW(JJ) IFR = IFR_ini + (JJ-J3) DO K=1, NRHS WCB(IFR+(K-1)*NCB) = RHS(J,K) RHS(J,K)=ZERO ENDDO 140 CONTINUE 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_667(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_698( & 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+J-1 PCB_PANEL = PPIV_PANEL+NBJ APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN IF ( NRHS == 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 CALL dtrsm( 'L','L','N','U', NBJ, NRHS, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF ENDIF ELSE IF (NRHS == 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 CALL dtrsm('L','L','N','N',NBJ, NRHS, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) 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 ( NRHS == 1 ) THEN CALL dtrsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, & WCB(PPIV_COURANT), 1 ) ELSE CALL dtrsm( 'L','U','T','U', NPIV, NRHS, ONE, & A(APOS), NPIV, WCB(PPIV_COURANT), & NPIV ) ENDIF ELSE IF ( MTYPE .eq. 1 ) THEN IF ( NRHS == 1) THEN CALL dtrsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE CALL dtrsm( 'L','U','T','U', NPIV, NRHS, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV ) ENDIF ELSE IF (NRHS == 1) THEN CALL dtrsv( 'L', 'N', 'N', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE CALL dtrsm('L','L','N','N',NPIV, NRHS, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV) 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 ( NRHS == 1 ) THEN CALL dgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), & NPIV, WCB(PPIV_COURANT), 1, ONE, & WCB(PCB_COURANT), 1) ELSE CALL dgemm('T', 'N', NUPDATE, NRHS, NPIV, ALPHA, & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) END IF ELSE IF ( NRHS == 1 ) THEN CALL dgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), & LIELL, WCB(PPIV_COURANT), 1, & ONE, WCB(PCB_COURANT), 1 ) ELSE CALL dgemm('N', 'N', NUPDATE, NRHS, NPIV, ALPHA, & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) END IF END IF END IF END IF IF (BUILD_POSINRHSCOMP) THEN POSINRHSCOMP(STEP(INODE)) = RHSCOMPFREEPOS RHSCOMPFREEPOS = RHSCOMPFREEPOS + NPIV ENDIF IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) IF ( KEEP(50) .eq. 0 ) THEN DO K=1,NRHS IFR = PPIV_COURANT + (K-1)*LD_WCBPIV RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = & WCB(IFR:IFR+NPIV-1) ENDDO ELSE IFR = PPIV_COURANT - 1 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 DO IF(JJ .GT. J3) EXIT IFR = IFR + 1 IF(IW(JJ+LIELL) .GT. 0) THEN DO K=1, NRHS RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR+(K-1)*LD_WCBPIV ) * A( APOS1 ) 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 DO K=1, NRHS POSWCB1 = IFR+(K-1)*LD_WCBPIV POSWCB2 = POSWCB1+1 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = WCB(POSWCB1)*A(APOS1) & + WCB(POSWCB2)*A(APOSOFF) RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A(APOSOFF) & + WCB(POSWCB2)*A(APOS2) 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 IFR = IFR+1 ENDIF ENDDO END IF IF (KEEP(201).GT.0) THEN CALL DMUMPS_598(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 IF ( MYROOT .EQ. 0 ) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN DUMMY (1) = 1 CALL DMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF) ENDIF END IF GO TO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN IF (MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 DO 190 I = 1, NUPDATE DO K=1, NRHS RHS( IW(J3 + I), K ) = RHS( IW(J3 + I), K ) & + WCB(PCB_COURANT + I-1 +(K-1)*LD_WCBCB) ENDDO 190 CONTINUE 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_78( NRHS, INODE, FPERE, NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), & MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), SLAVEF), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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_49( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CALL DMUMPS_72( NRHS, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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*KEEP(35) + & ( Effective_CB_Size + 4 ) * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS*KEEP(35) + & ( Effective_CB_Size + 4 ) * KEEP( 34 ) GOTO 260 END IF END DO END IF PLEFTWCB = PLEFTWCB - LIELL*NRHS 270 CONTINUE RETURN 260 CONTINUE CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE DMUMPS_302 RECURSIVE SUBROUTINE DMUMPS_303( 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, STEP, PROCNODE_STEPS, & RHS, LRHS & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB INTEGER LIW INTEGER(8) :: LA INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) 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)) INTEGER LRHS DOUBLE PRECISION RHS(LRHS, NRHS) LOGICAL FLAG INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) INTEGER MSGSOU, MSGTAG, MSGLEN 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 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_44( MYID, SLAVEF, COMM ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL DMUMPS_323( 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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) END IF END IF RETURN END SUBROUTINE DMUMPS_303 SUBROUTINE DMUMPS_249(N, A, LA, IW, LIW, W, LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , TO_PROCESS, SIZE_TO_PROCESS & ) USE DMUMPS_OOC USE DMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER N,LIW,LIWW,LWC,LPOOL,LNA INTEGER SLAVEF,MYLEAF,COMM,MYID INTEGER LPANEL_POS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NA(LNA),NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER PANEL_POS(LPANEL_POS) INTEGER INFO(40) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)),PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LRHS, NRHS DOUBLE PRECISION A(LA), RHS(LRHS,NRHS), 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(KEEP(28)) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) INTEGER LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) INTEGER MUMPS_275 EXTERNAL MUMPS_275 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INTEGER POSIWCB,POSWCB,K INTEGER(8) :: APOS, IST INTEGER NPIV INTEGER IPOS,LIELL,NELIM,IFR,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 DOUBLE PRECISION ALPHA,ONE,ZERO PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) LOGICAL BLOQ,DEBUT INTEGER PROCDEST, DEST INTEGER POSINDICES, IPOSINRHSCOMP INTEGER DUMMY(1) INTEGER 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 LOGICAL DEJA_SEND( 0:SLAVEF-1 ) INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & PTWCB_PANEL, NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL LOGICAL MUMPS_170 INTEGER MUMPS_330 EXTERNAL dgemv, dtrsv, dtrsm, dgemm, & MUMPS_330, & MUMPS_170 PLEFTW = 1 POSIWCB = LIWW POSWCB = LWC NROOT = 0 NBLEAF = NA(1) NBROOT = NA(2) DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_275(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_275(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_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, & SLAVEF) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) THEN GOTO 340 ENDIF ENDIF 50 CONTINUE BLOQ = ( ( III .EQ. IIPOOL ) & ) CALL DMUMPS_41( 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) 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 60 CONTINUE 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 DO JJ = J1, J2 J = IW( JJ ) IFR = IFR + 1 DO K=1,NRHS RHS(J,K) = RHS_ROOT(IFR+NPIV*(K-1)) END DO END DO 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)), & SLAVEF) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CALL DMUMPS_78( NRHS, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1 ), PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = LONG * KEEP(35) + & ( LONG + 2 ) * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = LONG * KEEP(35) + & ( LONG + 2 ) * 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_170( & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) TYPENODE = MUMPS_330(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 - NCB*NRHS .LT. PLEFTW - 1 ) THEN CALL DMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - NCB*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = NCB * NRHS - POSWCB - PLEFTW + 1 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 - NCB*NRHS PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = NCB 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 DO JJ = J1, J2 - KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*NCB) = RHS(J,K) ENDDO ENDDO IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1 DO K=1, NRHS IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+(K-1)*NCB) = ALPHA ELSE W(IFR+(K-1)*NCB) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL DMUMPS_63(NRHS, INODE, & W(Offset+PTRACB(STEP(INODE))), EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL DMUMPS_151(NRHS,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) IPOS = IPOS + 1 IF (KEEP(201).GT.0) THEN CALL DMUMPS_643( & 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_690( LIELL ) IF (KEEP(50).NE.1) THEN CALL DMUMPS_755( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL END IF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. LIELL*NRHS ) THEN CALL DMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. LIELL*NRHS ) THEN INFO(1) = -11 INFO(2) = LIELL*NRHS - POSWCB GOTO 330 END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN CALL DMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 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 - LIELL*NRHS PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = LIELL 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 (KEEP(252).EQ.0) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) DO K=1, NRHS IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-1)*LIELL) = ZERO ENDDO ELSE DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-1)*LIELL) = RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO ENDIF END DO IFR = PTWCB + NPIV - 1 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 DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*LIELL) = RHS(J,K) ENDDO ENDDO IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1 DO K=1, NRHS IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+(K-1)*LIELL) = ALPHA ELSE W(IFR+(K-1)*LIELL) = 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_641(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 + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN CALL DMUMPS_667(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_698( & 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 ( NRHS == 1 ) THEN IF (NCB_PANEL.NE.0) THEN CALL dgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( NBJ + PTWCB_PANEL ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ENDIF IF (MTYPE.NE.1) THEN CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL dtrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ENDIF ELSE IF (NCB_PANEL.NE.0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(NBJ+PTWCB_PANEL),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ENDIF IF (MTYPE.NE.1) THEN CALL dtrsm('L','L','T','U',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE CALL dtrsm('L','L','T','N',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) 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 (NRHS == 1) THEN CALL dgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(NPIV + PTWCB), 1, & ONE, & W(PTWCB), 1 ) ELSE CALL dgemm('T','N', NPIV, NRHS, NCB, ALPHA, A(IST), LIELL, & W(NPIV+PTWCB), LIELL, ONE, & W(PTWCB), LIELL) 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 ( NRHS == 1 ) THEN CALL dgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( NPIV + PTWCB ), & 1, ONE, & W(PTWCB), 1 ) ELSE CALL dgemm( 'N', 'N', NPIV, NRHS, NCB, ALPHA, & A(IST), NPIV, W(NPIV+PTWCB),LIELL, & ONE, W(PTWCB),LIELL) END IF END IF ENDIF IF ( MTYPE .eq. 1 ) THEN IF ( NRHS == 1 ) THEN CALL dtrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL dtrsm('L','L','T','N', NPIV, NRHS, ONE, A(APOS), & LIELL, W(PTWCB), LIELL) ENDIF ELSE IF ( KEEP(50) .EQ. 0 ) THEN IF ( NRHS == 1 ) THEN CALL dtrsv('U','N','U', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL dtrsm('L','U','N','U', NPIV, NRHS, ONE, A(APOS), & LIELL,W(PTWCB),LIELL) END IF ELSE IF ( NRHS == 1 ) THEN CALL dtrsv('U','N','U', NPIV, A(APOS), NPIV, & W(PTWCB), 1) ELSE CALL dtrsm('L','U','N','U',NPIV, NRHS, ONE, A(APOS), & NPIV, W(PTWCB), LIELL) END IF END IF END IF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF DO 150 I = 1, NPIV JJ = IW(J1 + I - 1) DO K=1, NRHS RHS(JJ, K) = W(PTWCB+I-1+(K-1)*LIELL) ENDDO 150 CONTINUE 160 CONTINUE IF (KEEP(201).GT.0) THEN CALL DMUMPS_598(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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_275(PROCNODE_STEPS(STEP(IF)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL DMUMPS_78( NRHS, IF, 0, 0, LIELL, & LIELL - KEEP(253), & IW( POSINDICES ), & W ( PTRACB(STEP( INODE ))), PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NPIV * KEEP(35) + 2 * 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_151(NRHS,N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF GOTO 50 330 CONTINUE CALL DMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, & SLAVEF) 340 CONTINUE CALL DMUMPS_150( MYID,COMM,BUFR, & LBUFR,LBUFR_BYTES ) RETURN END SUBROUTINE DMUMPS_249 RECURSIVE SUBROUTINE DMUMPS_41( & 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, RHS, & LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER LWC DOUBLE PRECISION W( LWC ) INTEGER POSIWCB, POSWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(40) INTEGER PLEFTW, KEEP( 500) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A( LA ), W2( KEEP(133) ) INTEGER LRHS, NRHS DOUBLE PRECISION RHS(LRHS, NRHS) INTEGER MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER STATUS( MPI_STATUS_SIZE ), IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN 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_44( MYID, SLAVEF, COMM ) ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL DMUMPS_42( 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) END IF END IF RETURN END SUBROUTINE DMUMPS_41 RECURSIVE SUBROUTINE DMUMPS_42( & 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) USE DMUMPS_OOC USE DMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER LWC DOUBLE PRECISION W( LWC ) INTEGER POSIWCB, POSWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(40) INTEGER PLEFTW, KEEP( 500) INTEGER(8) KEEP8(150) INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) 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 LRHS, NRHS DOUBLE PRECISION RHS(LRHS, NRHS) INTEGER MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER P_UPDATE, P_SOL_MAS, LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER I, JJ, IN, PROCDEST, J1, J2, IFR, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSCOMP 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 DEJA_SEND( 0:SLAVEF-1 ) INTEGER MUMPS_275 EXTERNAL MUMPS_275, dtrsv, dtrsm, dgemv, dgemm INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & PTWCB_PANEL, NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS 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, & LONG, 1, MPI_INTEGER, & COMM, IERR) IF ( POSIWCB - LONG - 2 .LT. 0 & .OR. POSWCB - PLEFTW + 1 .LT. LONG ) THEN CALL DMUMPS_95(NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ((POSIWCB - LONG - 2 ) .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG + 2 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1 .LT. LONG ) THEN INFO(1) = -11 INFO(2) = LONG + PLEFTW - POSWCB - 1 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=1,NRHS CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_DOUBLE_PRECISION, COMM, IERR) DO JJ=0, LONG-1 RHS(IWCB(POSIWCB+1+JJ),K) = W(POSWCB+1+JJ) 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_275(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 ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF (KEEP(201).GT.0) THEN CALL DMUMPS_643( & 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 .LT. PLEFTW - 1 ) THEN CALL DMUMPS_95(NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS .LT. PLEFTW - 1 ) THEN INFO(1) = -11 INFO(2) = LONG * NRHS- POSWCB WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + NPIV * NRHS PLEFTW = P_SOL_MAS + NROW_L * NRHS DO K=1, NRHS CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-1)*NROW_L),NROW_L, & MPI_DOUBLE_PRECISION, & COMM, IERR ) ENDDO IF (KEEP(201).EQ.1) THEN IF ( NRHS == 1 ) THEN CALL dgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE CALL dgemm( 'T', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) ENDIF ELSE IF ( NRHS == 1 ) THEN CALL dgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE CALL dgemm( 'N', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) END IF ENDIF IF (KEEP(201).GT.0) THEN CALL DMUMPS_598(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 100 CONTINUE CALL DMUMPS_63( NRHS, INODE, W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS 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 ) 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 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL END IF DO K=1, NRHS CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_DOUBLE_PRECISION, & COMM, IERR ) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0) THEN CALL DMUMPS_643( & 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_755( & 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_690(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 .LT. PLEFTW - 1 ) THEN CALL DMUMPS_95( NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 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 PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = LIELL 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(STEP(INODE)) IFR = PTRACB(STEP( INODE )) DO K=1, NRHS DO JJ = J1, J2 W(IFR+JJ-J1+(K-1)*LIELL) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO END DO IFR = PTRACB(STEP(INODE))-1+NPIV 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 DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*LIELL) = RHS(J,K) ENDDO ENDDO 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_641(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_PANEL = PTRACB(STEP(INODE)) + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL DMUMPS_667(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL DMUMPS_698( & 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 ( NRHS == 1 ) THEN IF (NCB_PANEL.NE.0) THEN CALL dgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( NBJ + PTWCB_PANEL ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ENDIF CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE IF (NCB_PANEL.NE.0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, & A(APOSDEB + int(NBJ,8)), LDAJ, & W(NBJ+PTWCB_PANEL),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ENDIF CALL dtrsm('L','L','T','U',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) 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 == 1 ) THEN CALL dgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & W(PTRACB(STEP(INODE))), 1 ) ELSE CALL dgemm( 'N', 'N', NPIV, NRHS, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, W(PTRACB(STEP(INODE))),LIELL) END IF ENDIF IF ( NRHS == 1 ) THEN CALL dtrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & W(PTRACB(STEP(INODE))),1) ELSE CALL dtrsm( 'L','U', 'N', 'U', NPIV, NRHS, ONE, & A(APOS), LDA, & W(PTRACB(STEP(INODE))),LIELL) END IF 1234 CONTINUE IF (KEEP(201).GT.0) THEN CALL DMUMPS_598(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 DO I = 1, NPIV JJ = IW( IPOS + I - 1 ) DO K=1,NRHS RHS( JJ, K ) = W( PTRACB(STEP(INODE))+I-1 & + (K-1)*LIELL ) ENDDO END DO 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL DMUMPS_151(NRHS, 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_275(PROCNODE_STEPS(STEP(IN)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_275( PROCNODE_STEPS(STEP(IN)), & SLAVEF ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 110 CALL DMUMPS_78( NRHS, IN, 0, 0, & LIELL, LIELL-KEEP(253), & IW( POSINDICES ) , & W( PTRACB(STEP(INODE))), & PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 110 ELSE IF ( IERR .eq. -2 ) THEN INFO(1) = -17 INFO(2) = LIELL * NRHS * KEEP(35) + & ( LIELL + 2 ) * KEEP(34) GOTO 260 ELSE IF ( IERR .eq. -3 ) THEN INFO(1) = -20 INFO(2) = LIELL * NRHS * KEEP(35) + & ( LIELL + 2 ) * 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_242( DUMMY, 1, MPI_INTEGER, MYID, & COMM, FEUILLE, SLAVEF ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL DMUMPS_151(NRHS, 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_151(NRHS, 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_44( MYID, SLAVEF, COMM ) 270 CONTINUE RETURN END SUBROUTINE DMUMPS_42 SUBROUTINE DMUMPS_641(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_641", & 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_641 SUBROUTINE DMUMPS_286( 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_290( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL DMUMPS_768 (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_156( 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_286 SUBROUTINE DMUMPS_768 (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_768 mumps-4.10.0.dfsg/src/dmumps_part1.F0000644000175300017530000064146311562233065017434 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE DMUMPS( id ) USE DMUMPS_OOC USE DMUMPS_STRUC_DEF IMPLICIT NONE C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), INTERFACE SUBROUTINE DMUMPS_758 &(idRHS, idINFO, idN, idNRHS, idLRHS) DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE DMUMPS_758 SUBROUTINE DMUMPS_26( id ) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id END SUBROUTINE DMUMPS_26 SUBROUTINE DMUMPS_142( id ) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id END SUBROUTINE DMUMPS_142 SUBROUTINE DMUMPS_301( id ) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id END SUBROUTINE DMUMPS_301 SUBROUTINE DMUMPS_349(id, LP) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE DMUMPS_349 END INTERFACE INCLUDE 'mpif.h' INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE (DMUMPS_STRUC) :: id INTEGER JOBMIN, JOBMAX, OLDJOB INTEGER I, J, MP, LP, MPG, KEEP235SAVE, KEEP242SAVE, & KEEP243SAVE LOGICAL LANAL, LFACTO, LSOLVE, PROK, FLAG, PROKG LOGICAL NOERRORBEFOREPERM LOGICAL UNS_PERM_DONE INTEGER COMM_SAVE INTEGER JOB, N, NZ, NELT INTEGER, PARAMETER :: ICNTL18DIST_MIN = 1 INTEGER, PARAMETER :: ICNTL18DIST_MAX = 3 INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV NOERRORBEFOREPERM = .FALSE. UNS_PERM_DONE = .FALSE. JOB = id%JOB N = id%N NZ = id%NZ NELT = id%NELT id%INFO(1) = 0 id%INFO(2) = 0 IF ( JOB .NE. -1 ) THEN LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.3)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (PROKG) THEN IF (id%ICNTL(5) .NE. 1) THEN WRITE(MPG,'(A,I4,I12,I15)') & 'Entering DMUMPS driver with JOB, N, NZ =', JOB,N,NZ ELSE WRITE(MPG,'(A,I4,I12,I15)') & 'Entering DMUMPS driver with JOB, N, NELT =', JOB,N & ,NELT ENDIF ENDIF ELSE MPG = 0 PROK = .FALSE. PROKG = .FALSE. LP = 6 MP = 6 END IF CALL MPI_INITIALIZED( FLAG, IERR ) IF ( .NOT. FLAG ) THEN WRITE(LP,990) 990 FORMAT(' Error in DMUMPS initialization: MPI is not running.') id%INFO(1) = -23 id%INFO(2) = 0 GOTO 500 END IF COMM_SAVE = id%COMM CALL MPI_COMM_DUP( COMM_SAVE, id%COMM, IERR ) CALL MPI_ALLREDUCE(JOB,JOBMIN,1,MPI_INTEGER,MPI_MAX, & id%COMM,IERR) CALL MPI_ALLREDUCE(JOB,JOBMAX,1,MPI_INTEGER,MPI_MIN, & id%COMM,IERR) IF ( JOBMIN .NE. JOBMAX ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF ( JOB .EQ. -1 ) THEN id%INFO(1)=0 id%INFO(2)=0 IF ( id%KEEP(40) .EQ. 1 - 456789 .OR. & id%KEEP(40) .EQ. 2 - 456789 .OR. & id%KEEP(40) .EQ. 3 -456789 ) THEN IF ( id%N > 0 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ENDIF ENDIF CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR) CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) THEN IF (id%KEEP(201).GT.0) THEN CALL DMUMPS_587(id, IERR) ENDIF GOTO 499 ENDIF CALL DMUMPS_163( id ) GOTO 500 END IF IF ( JOB .EQ. -2 ) THEN id%KEEP(40)= -2 - 456789 CALL DMUMPS_136( id ) GOTO 500 END IF IF ((JOB.LT.1).OR.(JOB.GT.6)) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF (id%MYID.EQ.MASTER) THEN IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN IF ((N.LE.0).OR.((N+N+N)/3.NE.N)) THEN id%INFO(1) = -16 id%INFO(2) = N END IF IF (id%ICNTL(5).NE.1) THEN IF (NZ.LE.0) THEN id%INFO(1) = -2 id%INFO(2) = NZ END IF ELSE IF (NELT.LE.0) THEN id%INFO(1) = -24 id%INFO(2) = NELT END IF ENDIF END IF IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF END IF CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 LANAL = .FALSE. LFACTO = .FALSE. LSOLVE = .FALSE. IF ((JOB.EQ.1).OR.(JOB.EQ.4).OR. & (JOB.EQ.6)) LANAL = .TRUE. IF ((JOB.EQ.2).OR.(JOB.EQ.4).OR. & (JOB.EQ.5).OR.(JOB.EQ.6)) LFACTO = .TRUE. IF ((JOB.EQ.3).OR.(JOB.EQ.5).OR. & (JOB.EQ.6)) LSOLVE = .TRUE. IF (MP.GT.0) CALL DMUMPS_349(id, MP) OLDJOB = id%KEEP( 40 ) + 456789 IF ( LANAL ) THEN 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 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 IF ( OLDJOB .LT. 1 .and. .NOT. LANAL ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF IF ( LSOLVE ) THEN IF ( OLDJOB .LT. 2 .AND. .NOT. LFACTO ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF #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 id%INFO(1)=-13 id%INFO(2)=id%N IF (id%ICNTL(1) .GT. 0 .AND. id%ICNTL(4) .GE.1) THEN WRITE(id%ICNTL(2),99993) END IF GOTO 510 ENDIF DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I END DO DO I = 1, id%NZ J = id%JCN(I) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I)=UNS_PERM_INV(J) END DO DEALLOCATE(UNS_PERM_INV) END IF END IF #endif CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 IF (LANAL) THEN id%KEEP(40)=-1 -456789 IF (id%MYID.EQ.MASTER) THEN id%INFOG(7) = -9999 id%INFOG(23) = 0 id%INFOG(24) = 1 IF (associated(id%IS1)) DEALLOCATE(id%IS1) IF ( id%ICNTL(5) .NE. 1 ) THEN 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 = 11 * N ELSE id%MAXIS1 = 10 * N END IF ELSE id%MAXIS1 = 6 * N + 2 * NELT + 2 ENDIF ALLOCATE( id%IS1(id%MAXIS1), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%MAXIS1 IF ( LP .GT.0 ) & WRITE(LP,*) 'Problem in allocating work array for analysis.' GO TO 100 END IF 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 ( LP .GT. 0 ) THEN WRITE(LP,*) 'Problem in allocating work array PROCNODE' END IF GOTO 100 END IF id%PROCNODE(1:id%N) = 0 IF ( id%ICNTL(5) .EQ. 1 ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP,*) 'Problem in allocating work array ELTPROC' END IF GOTO 100 END IF END IF IF ( id%ICNTL(5) .NE. 1 ) THEN id%NA_ELT=0 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 ELSE IF ( size( id%IRN ) < id%NZ ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE IF ( size( id%JCN ) < id%NZ ) THEN id%INFO(1) = -22 id%INFO(2) = 2 END IF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF (LP.GT.0) WRITE(LP,*) & '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 id%NA_ELT = 0 IF ( id%KEEP(50) .EQ. 0 ) THEN DO I = 1,NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) J = (J * J) id%NA_ELT = id%NA_ELT + J ENDDO ELSE DO I = 1,NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) J = (J * (J+1))/2 id%NA_ELT = id%NA_ELT + J ENDDO ENDIF ENDIF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF (LP.GT.0) WRITE(LP,*) & 'Error in analysis: ELTPTR/ELTVAR badly allocated.' END IF ENDIF 100 CONTINUE END IF CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(52) = id%ICNTL(8) IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 CALL DMUMPS_26( id ) 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 IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF IF (LFACTO) THEN id%KEEP(40) = 1 - 456789 IF ( id%MYID .EQ. MASTER ) THEN IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN id%SCHUR=>id%SCHUR_CINTERFACE & (1:id%SIZE_SCHUR*id%SIZE_SCHUR) 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 IF ( id%KEEP(55) .EQ. 0 ) THEN IF ( id%KEEP(54).eq.0 ) THEN IF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE IF ( size( id%A ) < id%NZ ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF END IF ELSE IF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE IF ( size( id%A_ELT ) < id%NA_ELT ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF CALL MUMPS_633(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) CALL DMUMPS_635(N,id%KEEP(1),id%ICNTL(1),MPG) 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.77) THEN IF (id%KEEP(50).EQ.1) THEN id%KEEP(52) = 0 ELSE 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 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 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 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 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 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 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 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(N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) id%INFO(1)=-13 END IF 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 ( LP .GT. 0 ) & WRITE(LP,*) 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL DMUMPS_758 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) CALL DMUMPS_807(id) CALL DMUMPS_769(id) ENDIF 200 CONTINUE END IF CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( id%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN id%SCHUR=>id%SCHUR_CINTERFACE & (1:id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) ENDIF 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 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 CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL DMUMPS_142(id) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) 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 IF ( id%INFO(1) .LT. 0 ) GO TO 499 id%KEEP(40) = 2 - 456789 END IF IF (LSOLVE) THEN id%KEEP(40) = 2 -456789 IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 ENDIF CALL DMUMPS_301(id) IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 id%KEEP(40) = 3 -456789 ENDIF IF (MP.GT.0) CALL DMUMPS_349(id, MP) GOTO 500 499 PROK = ((id%ICNTL(1).GT.0).AND. & (id%ICNTL(4).GE.1)) IF (PROK) WRITE (id%ICNTL(1),99995) id%INFO(1) IF (PROK) WRITE (id%ICNTL(1),99994) id%INFO(2) 500 CONTINUE #if ! defined(LARGEMATRICES) IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN IF (id%JOB .NE. 3 .OR. UNS_PERM_DONE) THEN DO I = 1, id%NZ J=id%JCN(I) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I)=id%UNS_PERM(J) END DO END IF END IF #endif 510 CONTINUE CALL DMUMPS_300(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) CALL MPI_BCAST( id%RINFOG(1), 40, MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I12)') ' On return from DMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I12)') ' On return from DMUMPS, INFOG(2)=', & id%INFOG(2) END IF CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE RETURN 99995 FORMAT (' ** ERROR RETURN ** FROM DMUMPS INFO(1)=', I3) 99994 FORMAT (' ** INFO(2)=', I10) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE DMUMPS SUBROUTINE DMUMPS_300( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INFO(40), INFOG(40), COMM, MYID INTEGER TMP1(2),TMP(2) INTEGER ROOT, IERR INTEGER MASTER PARAMETER (MASTER=0) IF ( INFO(1) .ge. 0 .and. INFO(2) .ge. 0 ) THEN INFOG(1) = INFO(1) INFOG(2) = INFO(2) ELSE INFOG(1) = INFO(1) 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 CALL MPI_BCAST(INFOG(3), 38, MPI_INTEGER, MASTER, COMM, IERR ) RETURN END SUBROUTINE DMUMPS_300 SUBROUTINE DMUMPS_349(id, LP) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LT.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) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SHUR) =',I10) END SUBROUTINE DMUMPS_349 SUBROUTINE DMUMPS_350(id, LP) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LT.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_350 SUBROUTINE DMUMPS_758 & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE 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_758 SUBROUTINE DMUMPS_807(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE 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_807 SUBROUTINE DMUMPS_769(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE 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 RETURN END SUBROUTINE DMUMPS_769 SUBROUTINE DMUMPS_24( 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 ), & 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_330, MUMPS_275, MUMPS_810 EXTERNAL MUMPS_330, MUMPS_275, MUMPS_810 INTEGER ISTEP, I, IPTRI, IPTRR, NCOL, NROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) KEEP(14) = 0 KEEP(13) = 0 DO I = 1, N ISTEP=abs(STEP(I)) ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_810 ( 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. 1.OR.ITYPE.EQ.2) .AND. & IRANK .EQ. MYID ) & .OR. & ( T4_MASTER_CONCERNED ) & ) THEN KEEP( 14 ) = KEEP( 14 ) + 3 + PTRAIW( I ) + PTRARW( I ) KEEP( 13 ) = KEEP( 13 ) + 1 + PTRAIW( I ) + PTRARW( I ) ELSE IF ( ITYPE .EQ. 3 ) THEN ELSE IF ( ITYPE .EQ. 2 .AND. I_AM_CAND_LOC ) THEN PTRARW( I ) = 0 KEEP(14) = KEEP(14) + 3 + PTRAIW( I ) + PTRARW( I ) KEEP(13) = KEEP(13) + 1 + PTRAIW( I ) + PTRARW( I ) END IF END DO IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( KEEP(14) > 0 ) THEN ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = KEEP(14) 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 IPTRR = 1 DO I = 1, N ISTEP = abs(STEP(I)) ITYPE = MUMPS_330( PROCNODE(ISTEP), SLAVEF ) IRANK = MUMPS_275( PROCNODE(ISTEP), SLAVEF ) TYPESPLIT = MUMPS_810 ( 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 = PTRAIW( I ) NROW = PTRARW( I ) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + NCOL + NROW + 3 IPTRR = IPTRR + NCOL + NROW + 1 ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NCOL = 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 + NCOL + NROW + 3 IPTRR = IPTRR + NCOL + NROW + 1 ELSE PTRAIW(I) = 0 PTRARW(I) = 0 END IF END DO IF ( IPTRI - 1 .NE. KEEP(14) ) THEN WRITE(*,*) 'Error 1 in anal_arrowheads', & ' IPTRI - 1, KEEP(14)=', IPTRI - 1, KEEP(14) CALL MUMPS_ABORT() END IF IF ( IPTRR - 1 .NE. KEEP(13) ) THEN WRITE(*,*) 'Error 2 in anal_arrowheads' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE DMUMPS_24 SUBROUTINE DMUMPS_148(N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & LP, COMM, root, KEEP, KEEP8, FILS, RG2L, & INTARR, DBLARR, PTRAIW, PTRARW, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES ) IMPLICIT NONE INCLUDE 'dmumps_root.h' INTEGER N,NZ, COMM, NBRECORDS 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) :: LA INTEGER PTRAIW( N ), PTRARW( N ), FRERE_STEPS( KEEP(28) ) INTEGER STEP(N) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION A( LA ), DBLARR(max(1,KEEP(13))) INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: BUFR INTEGER MUMPS_275, MUMPS_330, numroc, & MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, numroc, & MUMPS_810 DOUBLE PRECISION VAL INTEGER IOLD,JOLD,INEW,JNEW,ISEND,JSEND,DEST,I,K,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 I1, IA, JARR, ILOCROOT, JLOCROOT INTEGER IS1, ISHIFT, IIW, IS, IAS INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 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_330( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE = MUMPS_275( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_810( PROCNODE_STEPS(ISTEP), & SLAVEF ) I_AM_CAND_LOC = .FALSE. 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 = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL END IF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0 ) & .AND. IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF (MUMPS_275( PROCNODE_STEPS(abs(STEP(IARR))), & SLAVEF ) == MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL DMUMPS_310( 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 DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) & CALL DMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN CALL DMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN CALL DMUMPS_34( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( DEST .GT. 0 ) THEN CALL DMUMPS_34( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) IF ( T4MASTER.GT.0 ) THEN CALL DMUMPS_34( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN CALL DMUMPS_34( 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_18( & 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_148 SUBROUTINE DMUMPS_34(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_34 SUBROUTINE DMUMPS_18( & 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_18 RECURSIVE SUBROUTINE DMUMPS_310( 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_310(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL DMUMPS_310(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE DMUMPS_310 SUBROUTINE DMUMPS_145( 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, LDBLARR, LINTARR, & COMM INTEGER INTARR(LINTARR) INTEGER 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) 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, IA, I1, I, allocok INTEGER IS, IS1, ISHIFT, IIW, IAS INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 DOUBLE PRECISION VAL DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR 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 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 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_330( 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 IA = PTRARW(IARR) DBLARR(IA) = DBLARR(IA) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL ENDIF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) & .AND. IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_275( 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_310( 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_145 SUBROUTINE DMUMPS_266( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & TNBPROCFILS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, ITLOC, RHS_MUMPS, & IFLAG, IERROR ) USE DMUMPS_LOAD IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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 COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_RECU, NFRONT INTEGER LREQ INTEGER(8) :: LREQCB DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' INODE = BUFR( 1 ) NBPROCFILS = BUFR( 2 ) NROW = BUFR( 3 ) NCOL = BUFR( 4 ) NASS = BUFR( 5 ) NFRONT = BUFR( 6 ) NSLAVES_RECU = BUFR( 7 ) 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_190(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_22(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP,KEEP8, 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 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( 8 + NSLAVES_RECU : 7 + NSLAVES_RECU + NROW + NCOL ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_RECU.GT.0) & IW( IWPOSCB + 7+XTRA_SLAVES_UNSYM+KEEP(IXSZ): & IWPOSCB+6+KEEP(IXSZ)+NSLAVES_RECU ) = & BUFR( 8: 7 + NSLAVES_RECU ) ELSE IW( IWPOSCB + 7+KEEP(IXSZ) ) = 0 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( 8: 7 + NSLAVES_RECU ) END IF TNBPROCFILS(STEP( INODE )) = NBPROCFILS RETURN END SUBROUTINE DMUMPS_266 SUBROUTINE DMUMPS_163( id ) USE DMUMPS_STRUC_DEF USE DMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC) id INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) PAR_loc=id%PAR SYM_loc=id%SYM CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( PAR_loc .eq. 0 ) THEN 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 CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF CALL DMUMPS_20( 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%WRITE_PROBLEM="NAME_NOT_INITIALIZED" CALL MUMPS_SET_VERSION( id%VERSION_NUMBER ) id%OOC_TMPDIR="NAME_NOT_INITIALIZED" id%OOC_PREFIX="NAME_NOT_INITIALIZED" id%NRHS = 1 id%LRHS = 0 id%LREDRHS = 0 CALL DMUMPS_61( id%KEEP( 34 ), id%KEEP(35) ) NULLIFY(id%BUFR) id%MAXIS1 = 0 id%INST_Number = -1 id%N = 0; id%NZ = 0 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0 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) 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%POIDS) 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%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) 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%CB_SON_SIZE) 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) id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 id%SCHUR_NLOC = 0 id%SCHUR_LLD = 0 NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) CALL DMUMPS_637(id) NULLIFY(id%MEM_DIST) NULLIFY(id%SUP_PROC) id%Deficiency = 0 id%root%LPIV = -1 id%root%yes = .FALSE. id%root%gridinit_done = .FALSE. 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_163 SUBROUTINE DMUMPS_252( COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & & 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 & ) USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR 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) INTEGER IFLAG,IERROR,INODE,MAXFRW, & IWPOS, IWPOSCB, COMP INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 DOUBLE PRECISION A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)) INTEGER NSTK_S(KEEP(28)),PROCNODE_STEPS(KEEP(28)) INTEGER IPOOL( LPOOL ) INTEGER BUFR( LBUFR ) INTEGER IDUMMY(1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(N), PTRAIW(N), ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 INTARR(max(1,KEEP(14))) DOUBLE PRECISION DBLARR(max(1,KEEP(13))) INTEGER MUMPS_330 EXTERNAL MUMPS_330 INTEGER LP, HS, HF 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) :: SIZFR INTEGER SIZFI, NCB INTEGER J1,J2 INTEGER NCOLS, NROWS, LDA_SON INTEGER(8) :: JJ2, ICT13 #if defined(ALLOW_NON_INIT) INTEGER(8) :: NUMROWS, JJ3, JJ8, APOS_ini #endif INTEGER NELIM,JJ,JJ1,J3, & IBROT,IORG INTEGER JPOS,ICT11 INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4 INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER AINPUT 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 INCLUDE 'mumps_headers.h' INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_167 LOGICAL MUMPS_167 LOGICAL SSARBR LOGICAL COMPRESSCB INTEGER(8) :: LCB DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_170 LOGICAL MUMPS_170 COMPRESSCB =.FALSE. NELT = 1 LPTRAR = N NFS4FATHER = -1 IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (LEVEL.NE.1) THEN write(6,*) 'Error1 in mpi51f_niv1 ' CALL MUMPS_ABORT() ENDIF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_167(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) ENDDO 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 NASS = NASS + IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG LREQ_OOC = 0 IF (KEEP(201).EQ.1) THEN CALL DMUMPS_684( 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF 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_330(PROCNODE_STEPS(STEP(ISON)),SLAVEF) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_729(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. IF (KEEP(50).EQ.0 .AND. KEEP(234) .EQ. 0) THEN CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, & NFRONT_EFF, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, & PROCNODE_STEPS, SLAVEF ) ELSE CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP, KEEP8, IFLAG, & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF) IF (IFLAG.LT.0) GOTO 300 ENDIF IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_170(PROCNODE_STEPS(STEP(INODE)), & SLAVEF))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL DMUMPS_190(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 Write(*,*) ' ERROR 1 during ass_niv1', NFRONT, NFRONT_EFF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL DMUMPS_691(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 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 GOTO 280 ELSE CALL DMUMPS_94 & (N, KEEP(28), IW, LIW, A, LA, LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER,KEEP(216),LRLUS,KEEP(IXSZ)) COMP = COMP + 1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL DMUMPS_471(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLU) #if ! defined(ALLOW_NON_INIT) 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) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO ELSE IF (ETATASS.EQ.1) THEN APOS_ini = POSELT DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8,int(NASS1-1,8)) APOS = APOS_ini + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO ELSE APOS_ini = POSELT NUMROWS = min(NFRONT8, (IPTRLU-APOS_ini) / NFRONT8 ) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = APOS_ini + JJ8 * NFRONT8 A(APOS:APOS + JJ8) = ZERO ENDDO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = APOS_ini + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST_S(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 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)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) 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.LE.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB=( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB=( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS J1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1) THEN J2 = J1 + LSTK - 1 SIZFR = int(LSTK,8)*int(LSTK,8) IF (COMPRESSCB) SIZFR = (int(LSTK,8)*int(LSTK+1,8))/2_8 ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR = int(NELIM,8) * int(LSTK,8) ELSE SIZFR = int(NELIM,8) * int(NELIM,8) END IF J2 = J1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) OPASSW = OPASSW + dble(SIZFR) 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 + SIZFR - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (J2.GE.J1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC) RISK_OF_SAME_POS = IACHK + SIZFR - 1_8 .EQ. POSFAC - 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. & ((J2-J1).GT.300) DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * int(NFRONT,8) IACHK = IACHK_ini + int(JJ-J1,8)*int(LSTK,8) IF (RISK_OF_SAME_POS) THEN IF (JJ.EQ.J2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(IW(J1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(JJ>J1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) IF ( IACHK+int(JJ1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(JJ1 - 1,8)) A(IACHK + int(JJ1 -1,8)) = ZERO ENDIF ENDDO ELSE DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 A(JJ2) = A(IACHK + int(JJ1 - 1,8)) A(IACHK + int(JJ1 -1,8)) = ZERO ENDDO ENDIF ELSE DO JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1+JJ1-1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 1,8)) ENDDO ENDIF 170 CONTINUE END IF ELSE IF (LEVEL1) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (COMPRESSCB) THEN LCB = SIZFR ELSE LCB = int(LDA_SON,8)* int(J2-J1+1,8) ENDIF CALL DMUMPS_178(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), J2 - J1 + 1, NELIM, ETATASS, & COMPRESSCB, (ISON.EQ.ISON_IN_PLACE) & ) 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 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 J3 = J3 - 1 DO JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = 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_152(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_49( & 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_210( 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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .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_71( & 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_329( & 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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 JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) IJROW = INTARR(J1) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) Cduplicates --> CVD$ DEPCHK DO 240 JJ = J1, J2 APOS2 = ICT12 + int(INTARR(JJ),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + 1 240 CONTINUE IF (J3 .LE. J4) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = J4 - J3 + 1 Cduplicates--> CVD$ DEPCHK CduplicatesCVD$ NODEPCHK DO 250 JJ = 1, NBCOL APOS3 = ICT13 + int(INTARR(J3 + JJ - 1) - 1,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT + JJ - 1) 250 CONTINUE ENDIF IF (KEEP(50).EQ.0) THEN DO JJ=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ELSE DO JJ=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+JJ-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE GOTO 500 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_252' ENDIF GOTO 490 280 CONTINUE IFLAG = -9 CALL MUMPS_731(LAELL_REQ8 - LRLUS, IERROR) IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_252' ENDIF 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 DURING DMUMPS_252' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_252' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING DMUMPS_252' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 490 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_252 SUBROUTINE DMUMPS_253(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM , MEM_DISTRIB) USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER IFLAG,IERROR,INODE,MAXFRW, & LPOOL, LEAF, IWPOS, IWPOSCB, COMP INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC DOUBLE PRECISION A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, SLAVEF, 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 IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(N), PTRAIW(N), ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 INTARR(max(1,KEEP(14))) DOUBLE PRECISION DBLARR(max(1,KEEP(13))) INTEGER LP, HS, HF, HF_OLD,NCBSON, NSLAVES_OLD, & NBSPLIT INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER,I INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) :: LAELL8 INTEGER LREQ_OOC LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER NCB INTEGER J1,J2,J3,MP INTEGER(8) :: JJ8, LAPOS2, JJ2, JJ3 INTEGER NELIM,JJ,JJ1,NPIVS,NCOLS,NROWS, & IBROT,IORG INTEGER LDAFS, LDA_SON INTEGER JK,IJROW,NBCOL,NUMORG,IOLDPS,J4, NUMORG_SPLIT INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 INTEGER AINPUT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, ISLAVE, PDEST INTEGER PDEST1(1) INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6 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_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 DOUBLE PRECISION ZERO DOUBLE PRECISION RZERO PARAMETER(RZERO = 0.0D0 ) PARAMETER( ZERO = 0.0D0 ) INTEGER NELT, LPTRAR, NCBSON_MAX logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER (8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok, & NCB_SPLIT, SIZE_LIST_SPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER NBPANELS_L, NBPANELS_U MP = ICNTL(2) 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_330(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) .EQ. 1) THEN NCBSON_MAX = max & ( & IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)), NCBSON_MAX & ) 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 IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) SIZE_TMP_SLAVES_LIST = CAND( SLAVEF+1, INIV2 ) ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), & SLAVEF) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) 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 265 ENDIF CALL DMUMPS_791 ( & 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_472( 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_790 ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) TMP_SLAVES_LIST (1:SIZE_TMP_SLAVES_LIST) & = CAND (1:SIZE_TMP_SLAVES_LIST, INIV2) CALL DMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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_472( 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_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. IF (KEEP(50).EQ.0 .AND. KEEP(234).EQ.0) THEN CALL MUMPS_81(MYID, INODE, N, IOLDPS, HF, NFRONT, & NFRONT_EFF, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & PROCNODE_STEPS, SLAVEF ) ELSE ISON_IN_PLACE = -9999 CALL MUMPS_86( MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF) IF (IFLAG.LT.0) GOTO 250 ENDIF 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 plitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF 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 WRITE(6,*) ' Internal error 2 in fac_ass due', & ' to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF CALL MUMPS_ABORT() ELSE CALL DMUMPS_472( 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 JJ=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+JJ)=IW(IOLDPS+HF_OLD+JJ) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO JJ=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+JJ) = IW(IOLDPS+HF_OLD+JJ) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE Write(*,*) MYID,': ERROR 2 during ass_niv2, INODE=', INODE, & ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL DMUMPS_691(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST_S(STEP(INODE)) = IOLDPS 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+KEEP(IXSZ)) = NFRONT 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_461(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_533(SLAVEF,CAND(SLAVEF+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_533(SLAVEF,SLAVEF-1, & 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 CALL DMUMPS_471(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLU) POSEL1 = POSELT - int(LDAFS,8) #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, int(LDAFS-1,8) A(APOS:APOS+JJ8) = ZERO APOS = APOS + int(LDAFS,8) END DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN A(APOS:APOS+int(LDAFS,8)-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 + 1+KEEP(IXSZ)) 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.LE.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 + 2+KEEP(IXSZ)) ELSE NROWS = NCOLS ENDIF OPASSW = OPASSW + dble(NELIM*LSTK) J1 = ISTCHK + HS + NROWS + NPIVS J2 = J1 + 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 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * int(LDAFS,8) DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 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 CALL DMUMPS_178( A, LA, & POSELT, LDAFS, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), NELIM, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) DO 260 IORG = 1, NUMORG JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) IJROW = INTARR(J1) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO CduplicatesCVD$ NODEPCHK DO 240 JJ = J1, J2 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT))) ENDIF ELSE IF (INTARR(JJ).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) ENDIF ENDIF AINPUT = AINPUT + 1 240 CONTINUE IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = MAXARR ENDIF IF (J3 .GT. J4) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = J4 - J3 + 1 CduplicatesCVD$ NODEPCHK CduplicatesCVD$ NODEPCHK DO JJ = 1, NBCOL JJ3 = ICT13 + int(INTARR(J3 + JJ - 1),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT + JJ - 1) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO JJ = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & 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_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & IW(PDEST), NFRONT, COMM, IERR) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL DMUMPS_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & IW(PDEST), NFRONT, COMM, IERR) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST_S(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 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.LE.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) THEN IF(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 ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) IF (PDEST1(1).EQ.MYID) THEN CALL DMUMPS_211( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON))+HS+NROWS+NPIVS+NELIM CALL DMUMPS_71( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST_S(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_329( 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, ND, FRERE, LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_49( & 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_210( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .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_71( & INODE, NFRONT,NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST_S(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_329( 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, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & DMUMPS_253' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 GOTO 490 265 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING DMUMPS_253' ENDIF IFLAG = -13 IERROR = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_253' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING DMUMPS_253' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8-LRLUS, IERROR) 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_253' ENDIF IFLAG = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) IERROR = 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_253' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) 490 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_253 SUBROUTINE DMUMPS_39(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_39 SUBROUTINE DMUMPS_539 & (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), PTRARW(N), PTRAIW(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) DOUBLE PRECISION A(LA), & DBLARR(max(1,KEEP(13))) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSELT, ICT12, APOS INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS,JJ, & IN,AINPUT,JK,J1,J2,IJROW, ILOC INTEGER :: K1RHS, K2RHS, JFirstRHS 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 A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = & ZERO 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) AINPUT = PTRARW(IN) JK = PTRAIW(IN) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) IJROW = -ITLOC(INTARR(J1)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ= J1,J2 ILOC = ITLOC(INTARR(JJ)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT) ENDIF AINPUT = AINPUT + 1 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO 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_539 SUBROUTINE DMUMPS_531 & (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_531 SUBROUTINE DMUMPS_40(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 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 write(6,*) ' .. exit for col =', J 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_40 SUBROUTINE DMUMPS_178( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED, IS_INPLACE & ) 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, IS_INPLACE DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE, OMP_FLAG INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IF ( IS_INPLACE ) THEN 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 ENDIF 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN OMP_FLAG = (NROWS-NELIM).GE.300 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) .AND. .NOT. IS_INPLACE) 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) + & A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 END DO ENDIF END 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) & + A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_178 SUBROUTINE DMUMPS_530(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_530 SUBROUTINE DMUMPS_619( & 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(abs(A(JJ2)) .LT. VALSON(JJ1)) & A(JJ2) = VALSON(JJ1) ENDDO RETURN END SUBROUTINE DMUMPS_619 RECURSIVE SUBROUTINE DMUMPS_264( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE DMUMPS_OOC USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 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 PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 DOUBLE PRECISION DBLARR(max(1,KEEP(13))) 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 ) INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL INTEGER(8) :: POSBLOCFACTO 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 MUMPS_275 EXTERNAL MUMPS_275 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 ) LAELL = int(NPIV,8) * int(NCOL,8) IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_731(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_264" ENDIF GOTO 700 END IF CALL DMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731( 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_264" 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)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL DMUMPS_471(.FALSE., .FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, & MPI_DOUBLE_PRECISION, & COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF DO WHILE ( NBPROCFILS( STEP(INODE)) .NE. 0 ) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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)) 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 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 LPOS2 = POSELT + int(NPIV1,8) CALL dtrsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), NCOL, A(LPOS2), NCOL1) LPOS1 = POSBLOCFACTO+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) ENDIF 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 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) LAST_CALL = .FALSE. CALL DMUMPS_688( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( NPIV .GT. 0 ) THEN CALL dgemm('N','N', NCOL-NPIV,NROW1,NPIV, & ALPHA,A(LPOS1),NCOL, & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 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. LASTBL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) ' ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) IWPOS = IWPOS - NPIV 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_190( 1, .FALSE., FLOP1, KEEP,KEEP8 ) IF (LASTBL) THEN CALL DMUMPS_759( & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE DMUMPS_264 SUBROUTINE DMUMPS_699( 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_S, 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, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE DMUMPS_LOAD USE DMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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_S( KEEP(28) ) INTEGER NBPROCFILS( KEEP(28) ) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION DBLARR( max( 1,KEEP(13)) ) 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 STATUS( MPI_STATUS_SIZE ) INTEGER MUMPS_275, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_810 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 BLOCKING, SET_IRECV, MESSAGE_RECEIVED, IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT 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_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_810(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) DO WHILE ( PTRIST( STEP(INODE) ) .EQ. 0 ) MASTER = MUMPS_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MASTER, MAITRE_DESC_BANDE, & STATUS, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF (IFLAG.LT.0) RETURN END DO 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_731( LREQA - LRLUS, IERROR ) CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF CALL DMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..process_contrib' WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 CALL MUMPS_731( LREQA - LRLUS, IERROR ) CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END IF END IF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) 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))-1 ENDIF IF ( KEEP(55) .eq. 0 ) THEN CALL DMUMPS_539 & (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_123( & 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_40(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_531 & (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_39(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST_S, 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_617(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL DMUMPS_619(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - 1 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK .LT. IWPOSCB IF (SAME_PROC) THEN CALL DMUMPS_530(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, 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_152(.FALSE., MYID, N, ISTCHK, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN CALL DMUMPS_507( 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_500( & 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 POSFAC = POSFAC - LREQA CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) RETURN END SUBROUTINE DMUMPS_699 SUBROUTINE DMUMPS_143( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, UU, NOFFW, & NPVW, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS ) USE DMUMPS_OOC IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, 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(30) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK INTEGER NASS, NEL1, NPIVB, NPIVE, NBOLKJ, NBTLKJ DOUBLE PRECISION UUTEMP INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INCLUDE 'mumps_headers.h' EXTERNAL MUMPS_330, DMUMPS_221, DMUMPS_233, & DMUMPS_229, & DMUMPS_225, DMUMPS_232, DMUMPS_231, & DMUMPS_220, & DMUMPS_228, DMUMPS_236 INTEGER MUMPS_330 LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC 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 IBEG_BLOCK=1 NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IF (KEEP(201).EQ.1) THEN CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_BOTH_LU 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 50 CONTINUE CALL DMUMPS_221(NFRONT,NASS,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) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF GOTO 80 ENDIF IF (INOPV.EQ.2) THEN CALL DMUMPS_233(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP(IXSZ)) GOTO 50 ENDIF NPVW = NPVW + 1 IF (NASS.LE.1) THEN CALL DMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 GO TO 500 ENDIF CALL DMUMPS_225(IBEG_BLOCK,NFRONT, NASS, N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 50 IF (KEEP(201).EQ.1) THEN MonBloc%LastPiv= IW(IOLDPS+1+KEEP(IXSZ)) STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_U LAST_CALL = .FALSE. CALL DMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC ENDIF IF (IFINB.EQ.(-1)) GOTO 80 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV CALL DMUMPS_232(A,LA, & NFRONT,NPIV,NASS,POSELT,NBTLKJ) GO TO 50 80 CONTINUE NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IF (NPIV.LE.0) GO TO 110 NEL1 = NFRONT - NASS IF (NEL1.LE.0) GO TO 110 IF (KEEP(201).EQ.1) THEN STRAT = STRAT_TRY_WRITE TYPEFile = TYPEF_BOTH_LU MonBloc%LastPiv= NPIV CALL DMUMPS_642(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_231(A,LA,NFRONT, NPIV,NASS,POSELT) ENDIF 110 CONTINUE IF (MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) & .EQ.1) THEN NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 120 CALL DMUMPS_220(NFRONT,NASS,N,INODE,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) IF (INOPV.NE.1) THEN NPVW = NPVW + 1 CALL DMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,KEEP(IXSZ)) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVB = IBEG_BLOCK NPIVE = NPIV - NPIVB NEL1 = NFRONT - NASS IF ((NPIVE.LE.0).OR.(NEL1.EQ.0)) GO TO 500 CALL DMUMPS_236(A,LA,NPIVB, & NFRONT,NPIV,NASS,POSELT) ENDIF 500 CONTINUE IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) TYPEFile = TYPEF_BOTH_LU LAST_CALL = .TRUE. CALL DMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC CALL DMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE DMUMPS_143 RECURSIVE SUBROUTINE DMUMPS_322( & 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) 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) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(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 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 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( max(1,KEEP(14)) ) DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) INTEGER INIV2, ISHIFT, IBEG INTEGER MUMPS_275 EXTERNAL MUMPS_275 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 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) CHARACTER(LEN=35)::SUBNAME MP = ICNTL(2) LP = ICNTL(1) SUBNAME="??????" CALL DMUMPS_467(COMM_LOAD, KEEP) 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_269( MYID,KEEP,KEEP8, & 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_269" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL DMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL DMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_500( & 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_266( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, NBPROCFILS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, ITLOC, RHS_MUMPS, & IFLAG, IERROR ) SUBNAME="DMUMPS_266" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL DMUMPS_268(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, NBPROCFILS, & IPOOL, LPOOL, LEAF, & KEEP,KEEP8, ND, FILS, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="DMUMPS_268" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO ) THEN CALL DMUMPS_264( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL DMUMPS_263( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL DMUMPS_274( 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, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL DMUMPS_699( 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_S, 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, IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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).AND.(KEEP(48).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_210( 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_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL DMUMPS_700( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF) SUBNAME="DMUMPS_700" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(IROOT)), & SLAVEF ) IF ( PTLUST_S( STEP(IROOT)) .EQ. 0 ) THEN CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL DMUMPS_270( TMP( 1 ), TMP( 2 ), & 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, ND ) SUBNAME="DMUMPS_270" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL DMUMPS_700( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, NBPROCFILS, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF ) SUBNAME="DMUMPS_700" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL DMUMPS_271( 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GO TO 100 IF (MYID.NE.MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF)) THEN IF (KEEP(50).EQ.0) THEN IF (IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+6+KEEP(IXSZ)) = S_ROOT2SON_CALLED ELSE CALL DMUMPS_626( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ELSE IF (IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+8+KEEP(IXSZ)) = S_ROOT2SON_CALLED ELSE CALL DMUMPS_626( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) ENDIF ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL DMUMPS_270( 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_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, 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_273( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, KEEP,KEEP8, & COMM, COMM_LOAD, FILS, ND) SUBNAME="DMUMPS_273" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in DMUMPS_322" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine DMUMPS_322.',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_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE DMUMPS_322 RECURSIVE SUBROUTINE DMUMPS_280( & COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) 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) 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(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(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 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 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( max(1,KEEP(14)) ) DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) 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_44( MYID, SLAVEF, COMM ) RETURN ENDIF CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL DMUMPS_322( & 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) RETURN END SUBROUTINE DMUMPS_280 RECURSIVE SUBROUTINE DMUMPS_329( & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED ) 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) 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(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 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 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( max(1,KEEP(14)) ) DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) 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_467(COMM_LOAD, KEEP) 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 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_329' CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF IF ( FLAG ) THEN 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_322( 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_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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_280( COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_280( COMM_LOAD, ASS_IRECV, & 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_329 SUBROUTINE DMUMPS_255( INFO1, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE DMUMPS_COMM_BUFFER 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 STATUS( MPI_STATUS_SIZE ) LOGICAL NO_ACTIVE_IRECV INTEGER MSGSOU_LOC, MSGTAG_LOC 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) ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL DMUMPS_62 & (DUMMY, DEST, TAG_DUMMY, COMM, 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 RETURN END SUBROUTINE DMUMPS_255 SUBROUTINE DMUMPS_180( & INFO1, BUFR, LBUFR, LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, MP ) USE DMUMPS_COMM_BUFFER IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER COMM_NODES, COMM_LOAD, SLAVEF, INFO1, MP INTEGER STATUS( MPI_STATUS_SIZE ) LOGICAL FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS INTEGER MSGSOU_LOC, MSGTAG_LOC, COMM_EFF INTEGER IERR INTEGER IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS IF (SLAVEF.EQ.1) RETURN BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. 10 CONTINUE FLAG = .TRUE. DO WHILE ( FLAG ) COMM_EFF = COMM_NODES CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, & COMM_NODES, FLAG, STATUS, IERR) IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_LOAD CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM_LOAD, FLAG, STATUS, IERR) END IF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_RECV( BUFR, LBUFR_BYTES, & MPI_PACKED, MSGSOU_LOC, & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) ENDIF END DO IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN RETURN ENDIF CALL DMUMPS_469(BUFFERS_EMPTY) IF ( BUFFERS_EMPTY ) THEN IBUF_EMPTY = 0 ELSE IBUF_EMPTY = 1 ENDIF CALL MPI_ALLREDUCE(IBUF_EMPTY, & IBUF_EMPTY_ON_ALL_PROCS, & 1, MPI_INTEGER, MPI_MAX, & COMM_NODES, IERR) IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. ELSE BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. ENDIF GOTO 10 END SUBROUTINE DMUMPS_180 INTEGER FUNCTION DMUMPS_748 & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) K227_LOC = abs(K227) IF (K50.EQ.2) THEN K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) ELSE 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_748 = EFFECTIVE_SIZE RETURN END FUNCTION DMUMPS_748 SUBROUTINE DMUMPS_698( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) DOUBLE PRECISION THE_PANEL(NBROW, NBCOL) INTEGER I, IPERM DO I = 1, LPIV 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_698 SUBROUTINE DMUMPS_667(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) INTEGER I_NBPANELS, I_NASS I_NASS = IPOS I_NBPANELS = I_NASS + 1 NBPANELS = IW(I_NBPANELS) I_PIVPTR = I_NBPANELS + 1 I_PIV = I_PIVPTR + NBPANELS IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) NBPANELS = IW(I_NBPANELS) I_PIVPTR = I_NBPANELS + 1 I_PIV = I_PIVPTR + NBPANELS ENDIF RETURN END SUBROUTINE DMUMPS_667 SUBROUTINE DMUMPS_691(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) INTEGER IPOS_U IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: DMUMPS_691 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_691 SUBROUTINE DMUMPS_644 ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE DMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE IF (KEEP(50).EQ.1) RETURN IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE CALL DMUMPS_667(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 CALL DMUMPS_667(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 IF (FREESPACE) THEN IW(IBEGOOC) = -7777 IW(IOLDPS+XXI) = IBEGOOC - IOLDPS + 1 IWPOS = IBEGOOC+1 ENDIF RETURN END SUBROUTINE DMUMPS_644 SUBROUTINE DMUMPS_684(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE DMUMPS_OOC IMPLICIT NONE INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF NBPANELS_L = (NASS / DMUMPS_690(NBROW_L))+1 LREQ = 1 & + 1 & + NASS & + NBPANELS_L IF (K50.eq.0) THEN NBPANELS_U = (NASS / DMUMPS_690(NBCOL_U) ) +1 LREQ = LREQ + 1 & + NASS & + NBPANELS_U ENDIF RETURN END SUBROUTINE DMUMPS_684 SUBROUTINE DMUMPS_755 & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_755 mumps-4.10.0.dfsg/src/cmumps_load.F0000644000175300017530000065321311562233067017321 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE CMUMPS_LOAD implicit none PUBLIC :: CMUMPS_188, CMUMPS_185, & CMUMPS_189, CMUMPS_190, & CMUMPS_183, CMUMPS_187, & CMUMPS_186, CMUMPS_409, & CMUMPS_384, CMUMPS_461, & CMUMPS_467, CMUMPS_471, & CMUMPS_472, & CMUMPS_791, CMUMPS_790, & CMUMPS_792, CMUMPS_500, & CMUMPS_501, CMUMPS_520, & CMUMPS_513, & CMUMPS_514, CMUMPS_512 & ,CMUMPS_533, & CMUMPS_819, CMUMPS_818, & CMUMPS_820, CMUMPS_554, & CMUMPS_553, & CMUMPS_555 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) INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: FUTURE_NIV2 DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM #else DOUBLE PRECISION, SAVE, PRIVATE :: LAST_LOAD_SENT, & DM_LAST_MEM_SENT #endif 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,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 CMUMPS_188( COST_SUBTREE_ARG, K64, K66, & MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER K64, K66 INTEGER(8)::MAXS DOUBLE PRECISION T64, T66 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/1000_8) COST_SUBTREE = COST_SUBTREE_ARG END SUBROUTINE CMUMPS_188 SUBROUTINE CMUMPS_791 ( & 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_810 EXTERNAL MUMPS_810 LP = ICNTL(1) IN = INODE NBSPLIT = 0 NUMORG_SPLIT = 0 DO WHILE & ( & ( MUMPS_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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_791 SUBROUTINE CMUMPS_790 ( & 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_810 EXTERNAL MUMPS_810 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_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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_790 SUBROUTINE CMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & SON_SLAVE_LIST, NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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, & NCB, KEEP(500), NBSPLIT, & NSLSON, SIZE_SLAVES_LIST 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)) 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_792 SUBROUTINE CMUMPS_472( & 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_499( & 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_504( & 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_545' CALL MUMPS_ABORT() ENDIF ENDDO ELSE IF ( KEEP(48) == 5 ) THEN CALL CMUMPS_518( & 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_518' CALL MUMPS_ABORT() ENDIF ENDDO ELSE WRITE(*,*) "Strategy 6 not implemented" CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE CMUMPS_472 SUBROUTINE CMUMPS_499( & 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_12 EXTERNAL MUMPS_12 IF ( KEEP(48) == 0 .AND. KEEP(50) .NE. 0) THEN write(*,*) "Internal error 2 in CMUMPS_499." CALL MUMPS_ABORT() END IF IF ( KEEP(48) == 3 .AND. KEEP(50) .EQ. 0) THEN write(*,*) "Internal error 3 in CMUMPS_499." 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_409 & (MEM_DISTRIB, & CAND_OF_NODE, & & KEEP(69), SLAVEF, MSG_SIZE, & NMB_OF_CAND ) ELSE ITEMP=CMUMPS_186(KEEP(69),MEM_DISTRIB,MSG_SIZE) NMB_OF_CAND = SLAVEF - 1 END IF NSLAVES_LESS = max(ITEMP,1) NSLAVES_NODE = MUMPS_12(KEEP8(21), KEEP(48), & KEEP(50),SLAVEF, & NCB, NFRONT, NSLAVES_LESS, NMB_OF_CAND) CALL MUMPS_441( & KEEP,KEEP8, SLAVEF, & TAB_POS, & NSLAVES_NODE, NFRONT, NCB & ) IF (FORCE_CAND) THEN CALL CMUMPS_384(MEM_DISTRIB(0), & CAND_OF_NODE, SLAVEF, NSLAVES_NODE, & SLAVES_LIST) ELSE CALL CMUMPS_189(MEM_DISTRIB(0), & MSG_SIZE, SLAVES_LIST, NSLAVES_NODE) ENDIF RETURN END SUBROUTINE CMUMPS_499 SUBROUTINE CMUMPS_185( id, MEMORY_MD_ARG, MAXS ) USE CMUMPS_COMM_BUFFER USE CMUMPS_STRUC_DEF 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 INTEGER,DIMENSION(:),POINTER:: KEEP PARAMETER( ZERO=0.0d0 ) INTEGER WHAT INTEGER(8) MEMORY_MD, LA STEP_TO_NIV2_LOAD=>id%ISTEP_TO_INIV2 CAND_LOAD=>id%CANDIDATES ND_LOAD=>id%ND_STEPS KEEP_LOAD=>id%KEEP KEEP =>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 = KEEP(69) IF ( KEEP(47) .le. 0 .OR. KEEP(47) .gt. 4 ) THEN write(*,*) "Internal error 1 in CMUMPS_185" CALL MUMPS_ABORT() END IF CHK_LD=dble(0) BDC_MEM = ( KEEP(47) >= 2 ) BDC_POOL = ( KEEP(47) >= 3 ) BDC_SBTR = ( KEEP(47) >= 4 ) BDC_M2_MEM = ( ( KEEP(80) == 2 .OR. KEEP(80) == 3 ) & .AND. KEEP(47) == 4 ) BDC_M2_FLOPS = ( KEEP(80) == 1 & .AND. KEEP(47) .GE. 1 ) BDC_MD = (KEEP(86)==1) SBTR_WHICH_M = KEEP(90) REMOVE_NODE_FLAG=.FALSE. REMOVE_NODE_FLAG_MEM=.FALSE. REMOVE_NODE_COST_MEM=dble(0) REMOVE_NODE_COST=dble(0) IF (KEEP(80) .LT. 0 .OR. KEEP(80)>3) THEN WRITE(*,*) "Unimplemented KEEP(80) Strategy" CALL MUMPS_ABORT() ENDIF IF ((KEEP(80) == 2 .OR. KEEP(80)==3 ).AND. KEEP(47).NE.4) & THEN WRITE(*,*) "Internal error 3 in CMUMPS_185" CALL MUMPS_ABORT() END IF IF (KEEP(81) == 1 .AND. KEEP(47) < 2) THEN WRITE(*,*) "Internal error 2 in CMUMPS_185" CALL MUMPS_ABORT() ENDIF BDC_POOL_MNG = ((KEEP(81) == 1).AND.(KEEP(47) >= 2)) IF(KEEP(76).EQ.4)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST ENDIF IF(KEEP(76).EQ.5)THEN COST_TRAV=>id%COST_TRAV ENDIF IF(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 ALLOCATE(NIV2(id%NSLAVES), NB_SON(KEEP(28)), & POOL_NIV2(100),POOL_NIV2_COST(100), & stat=allocok) NB_SON=id%NE_STEPS NIV2=dble(0) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in CMUMPS_185' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES + 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_185' 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_185' 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_185' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF LU_USAGE=dble(0) MD_MEM=int(0,8) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN ALLOCATE(CB_COST_MEM(2*2000*id%NSLAVES), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in CMUMPS_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' 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_185' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF SBTR_CUR = dble(0) SBTR_MEM = dble(0) END IF CALL MUMPS_546(K34_LOC,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_185' id%INFO(1) = -13 id%INFO(2) = LBUF_LOAD_RECV RETURN ENDIF BUF_LOAD_SIZE = BUF_LOAD_SIZE * 20 CALL CMUMPS_54( 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_425(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_460( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEMORY_MD),dble(0) ,MYID, IERR ) WHAT=9 MEMORY_SENT = dble(LA-MAX_SURF_MASTER)-MAX_SBTR & - max( dble(LA) * dble(3) / dble(100), & dble(2) * dble(max(KEEP(5),KEEP(6))) * dble(KEEP(127))) IF (KEEP(12) > 25) THEN MEMORY_SENT = MEMORY_SENT - & dble(KEEP(12))*0.2d0*dble(LA)/100.0d0 ENDIF TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL CMUMPS_460( WHAT, & COMM_LD, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & MEMORY_SENT, & dble(0),MYID, IERR ) ENDIF RETURN END SUBROUTINE CMUMPS_185 SUBROUTINE CMUMPS_190( CHECK_FLOPS,PROCESS_BANDE, & INC_LOAD, KEEP,KEEP8 ) USE CMUMPS_COMM_BUFFER 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 (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_77( 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, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_190",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_190 SUBROUTINE CMUMPS_471( SSARBR, & PROCESS_BANDE_ARG, MEM_VALUE, NEW_LU, INC_MEM_ARG, & KEEP,KEEP8,LRLU) USE CMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_VALUE, INC_MEM_ARG, NEW_LU,LRLU 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 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_471." 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 #if defined(STATS_DYNAMIC_MEMORY) WRITE(*,*)MYID,': end of Incoherent state at time=', & MPI_WTIME()-TIME_REF #endif 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. #if defined(STATS_DYNAMIC_MEMORY) WRITE(*,*)MYID,': Begin of Incoherent state (1) at time=', & MPI_WTIME()-TIME_REF #endif 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_471', & 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.1d0*dble(LRLU))))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.1d0*dble(LRLU))))THEN IF ( abs( TMP_MEM-DM_LAST_MEM_SENT) > & DM_THRES_MEM ) THEN IERR = 0 SEND_MEM = TMP_MEM #endif 111 CONTINUE CALL CMUMPS_77( & 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,IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_471",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_471 INTEGER FUNCTION CMUMPS_186( 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_426(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_186 = NLESS RETURN END FUNCTION CMUMPS_186 SUBROUTINE CMUMPS_189(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_558(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_189 SUBROUTINE CMUMPS_183( INFO1, IERR ) USE CMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER, intent(in) :: INFO1 INTEGER, intent(out) :: IERR IERR=0 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_58( IERR ) CALL CMUMPS_150( MYID, COMM_LD, & BUF_LOAD_RECV, LBUF_LOAD_RECV, & LBUF_LOAD_RECV_BYTES ) DEALLOCATE(BUF_LOAD_RECV) END SUBROUTINE CMUMPS_183 #if defined (LAMPORT_) RECURSIVE SUBROUTINE CMUMPS_467(COMM, KEEP) #else SUBROUTINE CMUMPS_467(COMM, KEEP) #endif IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MSGTAG, MSGLEN, MSGSOU,COMM INTEGER KEEP(500) 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(65)=KEEP(65)+1 MSGTAG = STATUS( MPI_TAG ) MSGSOU = STATUS( MPI_SOURCE ) IF ( MSGTAG .NE. UPDATE_LOAD) THEN write(*,*) "Internal error 1 in CMUMPS_467", & 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_467", & 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_187( MSGSOU, BUF_LOAD_RECV, & LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES ) GOTO 10 ENDIF RETURN END SUBROUTINE CMUMPS_467 RECURSIVE SUBROUTINE CMUMPS_187 & ( MSGSOU, BUFR, LBUFR, LBUFR_BYTES ) 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_330 INTEGER MUMPS_330 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_819(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_187" 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_187" 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_187" 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_816(INODE_RECEIVED) ELSEIF(BDC_M2_FLOPS) THEN CALL CMUMPS_817(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_330(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_187" 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. & sqrt(epsilon(LOAD_RECEIVED)))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 WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() 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_187' 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_187' 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_187' 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_187" CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE CMUMPS_187 integer function CMUMPS_409 & (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_426(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_409 = nless return end function CMUMPS_409 subroutine CMUMPS_384 & (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_558 NMB_OF_CAND = CAND(SLAVEF+1) if(nslaves_inode.ge.NPROCS .or. & nslaves_inode.gt.NMB_OF_CAND) then write(*,*)'Internal error in CMUMPS_384', & 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_558(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_384 SUBROUTINE CMUMPS_425(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_425 SUBROUTINE CMUMPS_426(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_426 SUBROUTINE CMUMPS_461(MYID, SLAVEF, COMM, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, NSLAVES,INODE) USE CMUMPS_COMM_BUFFER 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 DOUBLE PRECISION MEM_INCREMENT ( NSLAVES ) DOUBLE PRECISION FLOPS_INCREMENT( NSLAVES ) DOUBLE PRECISION CB_BAND( NSLAVES ) IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN WHAT=1 ELSE WHAT=19 ENDIF #if ! defined(OLD_LOAD_MECHANISM) FUTURE_NIV2(MYID+1) = FUTURE_NIV2(MYID+1) - 1 IF ( FUTURE_NIV2(MYID+1) < 0 ) THEN WRITE(*,*) "Internal error in CMUMPS_461" CALL MUMPS_ABORT() ENDIF IF ( FUTURE_NIV2(MYID + 1) == 0 ) THEN 112 CONTINUE CALL CMUMPS_502(COMM,MYID,SLAVEF, & dble(MAX_SURF_MASTER),IERR) IF (IERR == -1 ) THEN CALL CMUMPS_467(COMM_LD, KEEP) GOTO 112 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_461", & IERR CALL MUMPS_ABORT() ENDIF TAB_MAXS(MYID) = TAB_MAXS(MYID) + int(MAX_SURF_MASTER,8) ENDIF #endif IF ( NSLAVES /= TAB_POS(SLAVEF + 2) ) THEN write(*,*) "Error 1 in CMUMPS_461", & 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_524(BDC_MEM, COMM, MYID, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT,IERR) IF ( IERR == -1 ) THEN CALL CMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_461", & 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 RETURN END SUBROUTINE CMUMPS_461 SUBROUTINE CMUMPS_500( & POOL, LPOOL, & PROCNODE, KEEP,KEEP8, SLAVEF, COMM, MYID, STEP, N, & ND, FILS ) USE CMUMPS_COMM_BUFFER 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_330 EXTERNAL MUMPS_330 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_330( 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_460( WHAT, & COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0),MYID, IERR ) POOL_LAST_COST_SENT = COST POOL_MEM(MYID)=COST IF ( IERR == -1 )THEN CALL CMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_500", & IERR CALL MUMPS_ABORT() ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_500 SUBROUTINE CMUMPS_501( & OK,INODE,POOL,LPOOL,MYID,SLAVEF,COMM,KEEP,KEEP8) USE CMUMPS_COMM_BUFFER 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_283,MUMPS_170 LOGICAL MUMPS_283,MUMPS_170 IF((INODE.LE.0).OR.(INODE.GT.N_LOAD)) THEN RETURN ENDIF IF (.NOT.MUMPS_170( & PROCNODE_LOAD(STEP_LOAD(INODE)), NPROCS) & ) THEN RETURN ENDIF IF(MUMPS_283(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_460( & WHAT, COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0),MYID, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 1 in CMUMPS_501", & 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_460( & WHAT, COMM, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, dble(0) ,MYID,IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_467(COMM_LD, KEEP) GOTO 112 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 3 in CMUMPS_501", & 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_501 SUBROUTINE CMUMPS_504 & (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_504" 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_558(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_558(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 #if defined (OLD_PART) 887 CONTINUE #endif 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_504" 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_504" 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_504' 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_504' 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_504' 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 #if ! defined (OLD_PART) i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 #if ! defined (PART1_) 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_504' 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 #endif 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 #if ! defined (PART1_) ENDIF #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 ! defined (PART1_) 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 #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 #else DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/ & dble(i)).NE.0)THEN GOTO 555 ENDIF ENDDO 555 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(i)) DO J=1,i IF(NB_ROWS(J)+X.GT.K821/NCB)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & ((K821/NCB)-NB_ROWS(J)) NB_ROWS(J)=(K821/NFRONT) ELSE IF ((TEMP(J)+dble((NB_ROWS(J)+X))* & dble(NFRONT)).GT. & PEAK)THEN AFFECTED=int((PEAK-(TEMP(J)+dble(NB_ROWS(J))* & dble(NFRONT))/dble(NFRONT)) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED NB_ROWS(J)=NB_ROWS(J)+AFFECTED ELSE NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDIF IF(((TEMP(J)+dble(NB_ROWS(J))*dble(NFRONT)) & .GT. PEAK) & .AND.(SMALL_SET.LT.OTHERS))THEN WRITE(*,*)MYID, & ':Internal error 8 in CMUMPS_504' SMALL_SET=SMALL_SET+1 CALL MUMPS_ABORT() ENDIF ENDDO SOMME=dble(0) DO J=1,CHOSEN SOMME=SOMME+NB_ROWS(J) ENDDO IF(ADDITIONNAL_ROWS.NE.0) THEN DO J=1,CHOSEN IF(NB_ROWS(J).LT.0)THEN WRITE(*,*)MYID, & ':Internal error 9 in CMUMPS_504' CALL MUMPS_ABORT() ENDIF IF ((TEMP(J)+dble(NB_ROWS(J)) & *dble(NFRONT)).GT. & PEAK)THEN WRITE(*,*)MYID, & ':Internal error 10 in CMUMPS_504' CALL MUMPS_ABORT() ENDIF IF ((TEMP(J)+dble(NB_ROWS(J)+ & ADDITIONNAL_ROWS)*dble(NFRONT)).GE. & PEAK)THEN AFFECTED=int((PEAK-(TEMP(J)+ & dble(NB_ROWS(J))* & dble(NFRONT))/dble(NFRONT)) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED NB_ROWS(J)=NB_ROWS(J)+AFFECTED IF((TEMP(J)+dble(NFRONT)* & dble(NB_ROWS(J))).GT. & PEAK)THEN WRITE(*,*)MYID, & ':Internal error 11 in CMUMPS_504' CALL MUMPS_ABORT() ENDIF ELSE NB_ROWS(J)=NB_ROWS(J)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 666 ENDDO IF(SMALL_SET.EQ.(NUMBER_OF_PROCS)) THEN NB_ROWS=0 GOTO 887 ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF(NB_ROWS(i)+ADDITIONNAL_ROWS.LT.K821/NFRONT) & THEN NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-(K821/ & NFRONT & -NB_ROWS(i)) NB_ROWS(i)=K821/NFRONT ENDIF i=i+1 ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/dble(i)) & .NE.0)THEN GOTO 372 ENDIF ENDDO 372 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 ENDIF #endif 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_504' CALL MUMPS_ABORT() ENDIF CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*) & 'Internal error 13 in CMUMPS_504' 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_504' 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_504' CALL MUMPS_ABORT() ENDIF END SUBROUTINE CMUMPS_504 SUBROUTINE CMUMPS_518 & (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_442 INTEGER MUMPS_442 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_442(int(NCB,8)*int(KMAX,8),K50,KMAX,NCB) NB_ROWS=0 CALL MUMPS_558(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_511(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_558(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 #if ! defined (OOC_PAR_MEM_SLAVE_SELECT) && ! defined (OOC_PAR_MEM2) CALL MUMPS_503(WHAT, KEEP,KEEP8, NCB, & NFRONT, min(NCB,OTHERS), J, X8) #endif 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_518' 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_558(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_518' 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_518' 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_518' 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_518' 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_558(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_518' 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_558(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_518' 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_518' CALL MUMPS_ABORT() ENDIF X=X+1 ENDIF ENDDO DO i=CHOSEN+1,NUMBER_OF_PROCS SLAVES_LIST(i)=TEMP_ID(i) ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*)MYID, & ': Internal error 17 in CMUMPS_518', & POS,NCB+1 CALL MUMPS_ABORT() ENDIF END SUBROUTINE CMUMPS_518 SUBROUTINE CMUMPS_520 & (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_508, & MUMPS_170 LOGICAL CMUMPS_508, & MUMPS_170 NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF(KEEP(47).LT.2)THEN WRITE(*,*)'CMUMPS_520 must & be called with K47>=2' CALL MUMPS_ABORT() ENDIF IF((INODE.GT.0).AND.(INODE.LE.N))THEN MEM_COST=CMUMPS_543(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_543(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_170(PROCNODE(STEP(INODE)), & SLAVEF))THEN WRITE(*,*) & 'Internal error 1 in CMUMPS_520' CALL MUMPS_ABORT() ENDIF UPPER=.FALSE. RETURN ENDIF INODE=POOL(LPOOL-2-NBTOP) UPPER=.TRUE. RETURN ENDIF ENDIF UPPER=.TRUE. END SUBROUTINE CMUMPS_520 SUBROUTINE CMUMPS_513(WHAT) IMPLICIT NONE LOGICAL WHAT IF(.NOT.BDC_POOL_MNG)THEN WRITE(*,*)'CMUMPS_513 & 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_513 DOUBLE PRECISION FUNCTION CMUMPS_543( INODE ) IMPLICIT NONE INTEGER INODE,LEVEL,i,NELIM,NFR DOUBLE PRECISION COST EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_330( 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_543=COST RETURN END FUNCTION CMUMPS_543 RECURSIVE SUBROUTINE CMUMPS_515(FLAG,COST,COMM) USE CMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL FLAG DOUBLE PRECISION COST DOUBLE PRECISION TO_BE_SENT EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_460( WHAT, & COMM, NPROCS, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & COST, & TO_BE_SENT, & MYID, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_467(COMM_LD, KEEP_LOAD) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_500", & IERR CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE CMUMPS_515 SUBROUTINE CMUMPS_512(INODE,STEP,NSTEPS,PROCNODE,FRERE, & NE,COMM,SLAVEF,MYID,KEEP,KEEP8,N) USE CMUMPS_COMM_BUFFER 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_170,MUMPS_275 LOGICAL MUMPS_170 INTEGER i,NCB,NELIM INTEGER MUMPS_275 INTEGER FATHER_NODE,FATHER,WHAT,IERR EXTERNAL MUMPS_330 INTEGER MUMPS_330 IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*)MYID,': Problem in CMUMPS_512' 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_170(PROCNODE(STEP(FATHER_NODE)), & SLAVEF)) THEN RETURN ENDIF FATHER=MUMPS_275(PROCNODE(STEP(FATHER_NODE)),SLAVEF) IF(FATHER.EQ.MYID)THEN IF(BDC_M2_MEM)THEN CALL CMUMPS_816(FATHER_NODE) ELSEIF(BDC_M2_FLOPS)THEN CALL CMUMPS_817(FATHER_NODE) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN IF(MUMPS_330(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_519(WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB, KEEP(81),MYID, & FATHER, IERR) IF (IERR == -1 ) THEN CALL CMUMPS_467(COMM, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_512", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE END SUBROUTINE CMUMPS_512 SUBROUTINE CMUMPS_514(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_515(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_515(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_514 RECURSIVE SUBROUTINE CMUMPS_816(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_816' 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 POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & CMUMPS_543(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_515(REMOVE_NODE_FLAG_MEM,MAX_M2,COMM_LD) NIV2(1+MYID)=MAX_M2 ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_816 RECURSIVE SUBROUTINE CMUMPS_817(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_817' 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 POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & CMUMPS_542(INODE) POOL_SIZE=POOL_SIZE+1 MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL CMUMPS_515(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_817 DOUBLE PRECISION FUNCTION CMUMPS_542(INODE) INTEGER INODE INTEGER NFRONT,NELIM,i,LEVEL EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_330( PROCNODE_LOAD(STEP_LOAD(INODE)), NPROCS ) COST=dble(0) CALL MUMPS_511(NFRONT,NELIM,NELIM, & KEEP_LOAD(50),LEVEL,COST) CMUMPS_542=COST RETURN END FUNCTION CMUMPS_542 INTEGER FUNCTION CMUMPS_541( 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_541=COST_CB RETURN END FUNCTION CMUMPS_541 SUBROUTINE CMUMPS_533(SLAVEF,NMB_OF_CAND, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, & NSLAVES,INODE) USE CMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, NASS, NSLAVES INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, intent(in) :: NMB_OF_CAND INTEGER, INTENT (IN) :: LIST_SLAVES( NMB_OF_CAND ) INTEGER KEEP(500),INODE INTEGER(8) KEEP8(150) INTEGER allocok DOUBLE PRECISION MEM_COST,FCT_COST DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE ::EMPTY_ARRAY, & DELTA_MD,EMPTY_ARRAY2 INTEGER NBROWS_SLAVE,i,WHAT,IERR,NPROCS_LOC LOGICAL FORCE_CAND MEM_COST=dble(0) FCT_COST=dble(0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. NPROCS_LOC=SLAVEF-1 ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) NPROCS_LOC=NMB_OF_CAND END IF IF(FORCE_CAND)THEN CALL CMUMPS_540(INODE,FCT_COST, & MEM_COST,NPROCS_LOC,NASS) ELSE CALL CMUMPS_540(INODE,FCT_COST, & MEM_COST,SLAVEF-1,NASS) ENDIF DO i=1,SLAVEF IDWLOAD(i)=i-1 ENDDO ALLOCATE(EMPTY_ARRAY(NPROCS_LOC),DELTA_MD(NPROCS_LOC), & EMPTY_ARRAY2(NPROCS_LOC), & stat=allocok) DO i = 1, NSLAVES NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) DELTA_MD( i ) = FCT_COST - dble(NBROWS_SLAVE)* & dble(NASS) END DO IF(FORCE_CAND)THEN DO i=NSLAVES+1,NPROCS_LOC DELTA_MD( i ) = FCT_COST ENDDO ELSE DO i=NSLAVES+1,SLAVEF-1 DELTA_MD( i ) = FCT_COST ENDDO ENDIF WHAT=7 111 CONTINUE CALL CMUMPS_524(.FALSE., COMM_LD, MYID, SLAVEF, #if ! defined(OLD_LOAD_MECHANISM) & FUTURE_NIV2, #endif & NPROCS_LOC, LIST_SLAVES,0, & EMPTY_ARRAY, & DELTA_MD,EMPTY_ARRAY2,WHAT, IERR) IF ( IERR == -1 ) THEN CALL CMUMPS_467(COMM_LD, KEEP) GOTO 111 ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_533", & IERR CALL MUMPS_ABORT() ENDIF #if ! defined(OLD_LOAD_MECHANISM) IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN #endif DO i = 1, NSLAVES MD_MEM(LIST_SLAVES(i))=MD_MEM(LIST_SLAVES(i))+ & int(DELTA_MD( 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 ENDDO #if ! defined(OLD_LOAD_MECHANISM) ENDIF #endif DEALLOCATE(EMPTY_ARRAY) DEALLOCATE(DELTA_MD) END SUBROUTINE CMUMPS_533 SUBROUTINE CMUMPS_540(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_540 SUBROUTINE CMUMPS_819(INODE) IMPLICIT NONE INTEGER INODE INTEGER i,J,SON,NSLAVES_TEMP,POS_TEMP,K INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_275( & 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_819 SUBROUTINE CMUMPS_820(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_820 SUBROUTINE CMUMPS_554(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_554 SUBROUTINE CMUMPS_818(INODE,MAX_MEM,PROC) IMPLICIT NONE INTEGER INODE,PROC INTEGER i,POS,NSLAVES,SLAVE,NCAND,J,NELIM,NCB,NFRONT,SON,K INTEGER allocok EXTERNAL MUMPS_330 INTEGER MUMPS_330 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_818' CALL MUMPS_ABORT() ENDIF ALLOCATE( CONCERNED(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_818' CALL MUMPS_ABORT() ENDIF ALLOCATE( RECV_BUF(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_818' 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_330(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_543(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_330(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_818' 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_818 SUBROUTINE CMUMPS_553(MIN_PROC,POOL, & LPOOL,INODE) IMPLICIT NONE INTEGER INODE,LPOOL,MIN_PROC INTEGER POOL(LPOOL) EXTERNAL MUMPS_275 INTEGER MUMPS_275 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_275(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_275(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_553 SUBROUTINE CMUMPS_555(POOL, LPOOL,KEEP,KEEP8) IMPLICIT NONE INTEGER LPOOL,POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER i,POS EXTERNAL MUMPS_283 LOGICAL MUMPS_283 IF(.NOT.BDC_SBTR) RETURN POS=0 DO i=NB_SUBTREES,1,-1 DO WHILE(MUMPS_283( & 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_555 END MODULE CMUMPS_LOAD mumps-4.10.0.dfsg/src/mumps_io_err.h0000644000175300017530000000637611562233011017547 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #include #include "mumps_common.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 */ int mumps_io_error(int mumps_errno, const char* desc); /* Export a system error to the Fortran layer (errno must be set) Returns mumps_errno for convenience */ int mumps_io_sys_error(int mumps_errno, const char* desc); #if ! ( defined(MUMPS_WIN32) || defined(WITHOUT_PTHREAD) ) int mumps_io_init_err_lock(); int mumps_io_destroy_err_lock(); int mumps_check_error_th(); MUMPS_INLINE int mumps_io_protect_err(); MUMPS_INLINE int mumps_io_unprotect_err(); #endif /* ! ( MUMPS_WIN32 || WITHOUT_PTHREAD ) */ mumps-4.10.0.dfsg/src/cmumps_part3.F0000644000175300017530000071326711562233067017441 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C RECURSIVE SUBROUTINE CMUMPS_210( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' TYPE (CMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 40 ), KEEP(500) INTEGER(8) KEEP8(150) 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(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(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(max(1,KEEP(13))) INTEGER INTARR(max(1,KEEP(14))) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER 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, ISTCHK, ISTCHK_LOC INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER INTEGER NFRONT INTEGER(8) :: SIZFR INTEGER LDA_SON INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, IROW_SON, & NPIV, NROWS_TO_STACK, II, COLLIST INTEGER(8) :: POSROW, SHIFTCB_SON INTEGER NBCOLS_EFF INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP INTEGER ITMP LOGICAL SAME_PROC, COMPRESSCB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE, TYPESPLIT INTEGER KEEP253_LOC INCLUDE 'mumps_headers.h' INTEGER MUMPS_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_810(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 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_210' 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_275( 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_210' 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_210' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN DO WHILE ( PTRIST(STEP( ISON )) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & PDEST_MASTER_ISON, MAITRE_DESC_BANDE, & 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_47( & 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_210' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) 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_47( & 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) DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .EQ. MYID ) THEN NBPROCFILS(STEP(INODE_PERE)) = & NBPROCFILS(STEP(INODE_PERE)) - 1 IF ( PDEST .EQ. PDEST_MASTER ) THEN NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 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_729(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 (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL CMUMPS_539 & (N, INODE_PERE, 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_123(NELT, FRTPTR, FRTELT, & N, INODE_PERE, 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_47( & 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 (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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE CALL CMUMPS_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_40(N, INODE_PERE, & 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) EXIT ELSE CALL CMUMPS_40(N, INODE_PERE, & 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) 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_210" CALL MUMPS_ABORT() ELSE POSROW = PTRAST(STEP(ISON))+SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL CMUMPS_617(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER GOTO 600 ENDIF ITMP=-9999 IF ( LMAP_LOC-NBROW(1)+1-KEEP253_LOC .NE. 0 ) THEN CALL CMUMPS_618( & 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_757( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF CALL CMUMPS_619(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL CMUMPS_530(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST_S, 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_152(.FALSE., MYID, N, & ISTCHK_LOC, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 ) THEN CALL CMUMPS_507( 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_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL CMUMPS_531 & (N, INODE_PERE, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF END IF END DO 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) 95 CONTINUE IF ( PTRIST(STEP(ISON)) .lt.0 .or. & IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) .GT. N ) 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 CALL CMUMPS_67( 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_210" 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_210" 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_210" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF GO TO 95 END IF END IF END DO ITYPE = MUMPS_330(PROCNODE_STEPS(STEP(ISON)), SLAVEF) IF (KEEP(214) .EQ. 2) THEN CALL CMUMPS_314( 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, ITYPE & ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL CMUMPS_626( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP &) 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_44( MYID, SLAVEF, COMM ) ENDIF RETURN END SUBROUTINE CMUMPS_210 SUBROUTINE CMUMPS_211( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE CMUMPS_COMM_BUFFER 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) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW COMPLEX A( LA ) 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(max(1,KEEP(13))) 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_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER INTARR(max(1,KEEP(14))) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER 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 INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL COMPRESSCB INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_211' 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_211' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_275( & 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_211' 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_47( & 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_211' 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_47( & 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 NBPROCFILS(STEP(INODE_PERE))=NBPROCFILS(STEP(INODE_PERE))-1 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 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_211 ', 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 DO II = 1,NROWS_TO_STACK IROW_SON=PERM(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_47( & 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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_617(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during CMUMPS_211" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253).GT. 0 ) THEN CALL CMUMPS_618( & A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253), & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB, & NELIM+NBROW(1)) ELSE CALL CMUMPS_757(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF CALL CMUMPS_619(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL CMUMPS_530(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST_S, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 ) THEN CALL CMUMPS_507( 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_500( & 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 CALL CMUMPS_67(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_211" 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_211" 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_211" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_211' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_152(.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_44(MYID, SLAVEF, COMM ) RETURN END SUBROUTINE CMUMPS_211 SUBROUTINE CMUMPS_93(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR) USE CMUMPS_LOAD USE CMUMPS_OOC 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 INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZECB, IAPOS, I LOGICAL MOVEPTRAST 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) 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_724( 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_576(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in CMUMPS_576' 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 ELSE POSFAC = POSFAC - SIZECB LRLU = LRLU + SIZECB LRLUS = LRLUS + SIZECB - SIZE_INPLACE ENDIF 500 CONTINUE CALL CMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE,KEEP,KEEP8,LRLU) RETURN END SUBROUTINE CMUMPS_93 SUBROUTINE CMUMPS_314( 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, 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) 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 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) ) 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_729(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 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL CMUMPS_688 & ( 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_731(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL CMUMPS_94( N,KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress Stack_band:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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)) IF(KEEP(201).NE.2)THEN CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLU) ELSE CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI+XXI)=LREQI CALL MUMPS_730(LREQA, IW(POSI+XXR)) CALL MUMPS_730(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXS)=-9999 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_576(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in CMUMPS_576' IERROR=0 GOTO 700 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLU) 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_190(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL CMUMPS_190(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE CMUMPS_314 SUBROUTINE CMUMPS_626( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) IMPLICIT NONE include 'mumps_headers.h' INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB 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_152(.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_626 SUBROUTINE CMUMPS_214( KEEP,KEEP8, & MYID, N, NELT, LNA, NZ, NA_ELT, 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, NZ, NA_ELT INTEGER(8), INTENT(OUT) :: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES 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, CMUMPS_LBUFR_BYTES, CMUMPS_LBUF 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 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 + int(KEEP(13),8) 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 + int(KEEP(14),8) 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 NBRECORDS = min(KEEP(39), NZ) ELSE NBRECORDS = min(KEEP(39), NA_ELT) 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_BYTES = KEEP( 44 ) * KEEP( 35 ) CMUMPS_LBUFR_BYTES = max( CMUMPS_LBUFR_BYTES, & 100000 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF CMUMPS_LBUFR_BYTES = CMUMPS_LBUFR_BYTES & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUFR_BYTES)/100E0) NB_BYTES = NB_BYTES + int(CMUMPS_LBUFR_BYTES,8) CMUMPS_LBUF = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 43 ) * KEEP( 35 )) ) CMUMPS_LBUF = max( CMUMPS_LBUF, 100000 ) CMUMPS_LBUF = CMUMPS_LBUF & + int( 2.0E0 * real(max(PERLU,0))* & real(CMUMPS_LBUF)/100E0) CMUMPS_LBUF = max(CMUMPS_LBUF, CMUMPS_LBUFR_BYTES) NB_BYTES = NB_BYTES + int(CMUMPS_LBUF,8) 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 + 5_8 * NSTEPS8 + 3_8 NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI 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_214 SUBROUTINE CMUMPS_757(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_757 SUBROUTINE CMUMPS_618( & 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_618 SUBROUTINE CMUMPS_710 (id, NB_INT,NB_CMPLX ) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 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%POIDS)) NB_INT=NB_INT+size(id%POIDS) 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) 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%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)) & NB_INT=NB_INT+size(id%POSINRHSCOMP) IF (associated(id%MEM_SUBTREE)) & NB_INT=NB_INT+size(id%MEM_SUBTREE) 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%COST_TRAV)) NB_INT=NB_INT+size(id%COST_TRAV) 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) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR) 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%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)) NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA)) 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_CMPLX = NB_CMPLX + NB_REAL/2_8 RETURN END SUBROUTINE CMUMPS_710 SUBROUTINE CMUMPS_756(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 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 RETURN END SUBROUTINE CMUMPS_756 SUBROUTINE CMUMPS_22( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8, & 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) 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_22", & 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_730(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_632(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL CMUMPS_627(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_627(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_630( 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_724(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_94(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ)) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... alloc_cb', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF DONE = .TRUE. COMP = COMP + 1 ENDIF ENDIF IF (IWPOSCB-IWPOS+1 .LT. LREQ) THEN IF (DONE) GOTO 600 CALL CMUMPS_94(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ)) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... alloc_cb', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF COMP = COMP + 1 IF (IWPOSCB-IWPOS+1 .LT. LREQ) GOTO 600 ENDIF IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in CMUMPS_22",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_22",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_730(LREQCB, IW(IWPOSCB+1+XXR)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF KEEP8(67) = min(LRLUS, KEEP8(67)) #if ! defined(OLD_LOAD_MECHANISM) CALL CMUMPS_471(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #else #if defined (CHECK_COHERENCE) CALL CMUMPS_471(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #else CALL CMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #endif #endif RETURN 600 IFLAG = -8 IERROR = LREQ RETURN 620 IFLAG = -9 CALL MUMPS_731(LREQCB_EFF - LRLUS, IERROR) RETURN END SUBROUTINE CMUMPS_22 SUBROUTINE CMUMPS_244(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) USE CMUMPS_LOAD 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(*) 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 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))) INTEGER INTARR(max(1,KEEP(14))) COMPLEX DBLARR(max(1,KEEP(13))) REAL SEUIL, SEUIL_LDLT_NIV2 INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INTEGER MUMPS_275 EXTERNAL MUMPS_275 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) 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 IPTRLU = LRLU NTOTPV = 0 NMAXNPIV = 0 IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_362(N, LEAF, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL CMUMPS_506(POOL, LPOOL, LEAF) CALL CMUMPS_555(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_275( PROCNODE_STEPS(STEP(KEEP(38))), SLAVEF ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF CALL CMUMPS_251(N,IW,LIW,A,LA,IW1(NSTK),IW1(NBPROCFILS), & INFO(1),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, INFO(2), 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) POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN KEEP8(31) = POSFAC ENDIF KEEP(32) = IWPOS CALL MUMPS_735(KEEP8(31), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) 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 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), INFO(12), & 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/ & ' --- (12) NUMBER OF OFF DIAGONAL PIVOTS =',I15/ & ' --- (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) 99990 FORMAT(/ ' NUMBER OF MSGS RECVD FOR DYNAMIC LOAD =',I15) END SUBROUTINE CMUMPS_244 SUBROUTINE CMUMPS_269( MYID,KEEP,KEEP8, & 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) 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_22( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, 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_269 SUBROUTINE CMUMPS_270( 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_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, 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) 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_S(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), PTRARW(N), PTRAIW(N) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) COMPLEX DBLARR(max(1,KEEP(13))) 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_275 EXTERNAL numroc, MUMPS_275 IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_275( 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_270" CALL MUMPS_ABORT() ENDIF ENDIF PTLUST_S(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_94( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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_S(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST_S( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_730( LREQA, IW(POSHEAD + XXR)) IW( POSHEAD + XXS )=-9999 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_731(LREQA - LRLUS, IERROR) GOTO 700 END IF CALL CMUMPS_94( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB2 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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_S(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = max(POSFAC-1_8,1_8) PTRFAC (STEP(IROOT)) = max(POSFAC-1_8,1_8) 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) CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) POSHEAD = PTLUST_S( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_730( LREQA, IW(POSHEAD + XXR)) IW( POSHEAD + XXS ) = S_NOTFREE 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 ( KEEP( 50 ) .eq. 0 .OR. KEEP(50) .eq. 2 ) THEN OPELIW = OPELIW + ( dble(2*TOT_ROOT_SIZE) * & dble(TOT_ROOT_SIZE) * dble(TOT_ROOT_SIZE ) / dble(3) & - 0.5d0 * dble( TOT_ROOT_SIZE ) * dble( TOT_ROOT_SIZE ) & - dble( TOT_ROOT_SIZE ) / dble( 6 ) ) & / dble( root%NPROW * root%NPCOL ) ELSE OPELIW = OPELIW + ( dble(TOT_ROOT_SIZE) * & dble( TOT_ROOT_SIZE) * & dble( TOT_ROOT_SIZE + 1 ) ) & / dble( 3 * root%NPROW * root%NPCOL ) END IF 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_756(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL CMUMPS_96( 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_152(.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 ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_681(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL CMUMPS_580(IERR) ENDIF CALL CMUMPS_507( 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_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL CMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE CMUMPS_270 SUBROUTINE CMUMPS_96 &( 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_96 INTEGER FUNCTION CMUMPS_505(KEEP,KEEP8) IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) CMUMPS_505 = KEEP(28) + 1 + 3 RETURN END FUNCTION CMUMPS_505 SUBROUTINE CMUMPS_506(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_506 SUBROUTINE CMUMPS_507 & (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_170 LOGICAL MUMPS_170, 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_170(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_514(INODE,1) ENDIF ENDIF IF ( MUMPS_170(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))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)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)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_507 LOGICAL FUNCTION CMUMPS_508(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) CMUMPS_508 = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION CMUMPS_508 SUBROUTINE CMUMPS_509( 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_167, MUMPS_283, CMUMPS_508 LOGICAL MUMPS_167, MUMPS_283, CMUMPS_508 EXTERNAL MUMPS_275 INTEGER MUMPS_275 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 #if defined(POOL_EXTRACT_MNG) INTEGER POS_TO_EXTRACT #endif 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_509: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( CMUMPS_508(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in CMUMPS_509" 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_509" 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_561(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_820(FLAG_MEM) IF(FLAG_MEM)THEN CALL CMUMPS_561(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_167( PROCNODE(STEP(INODE_EFF)), SLAVEF) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL CMUMPS_513(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_283( PROCNODE(STEP(INODE_EFF)), & SLAVEF)) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL CMUMPS_513(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in CMUMPS_509", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL CMUMPS_520 & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_167( PROCNODE(STEP(INODE)), & SLAVEF) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_283( PROCNODE(STEP(INODE)), & SLAVEF)) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL CMUMPS_561(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 defined(POOL_EXTRACT_MNG) IF(KEEP(76).EQ.4)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.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 #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ELSE IF(DEPTH_FIRST_LOAD(STEP(POOL(LPOOL-2-I))).LT. & DEPTH_FIRST_LOAD(STEP(NODE_TO_EXTRACT))) & THEN POS_TO_EXTRACT=I #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ENDIF ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) INODE = NODE_TO_EXTRACT #else INODE = INODE_EFF #endif DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ENDIF IF(KEEP(76).EQ.5)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.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 #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ELSE IF(COST_TRAV(STEP(POOL(LPOOL-2-I))).GT. & COST_TRAV(STEP(NODE_TO_EXTRACT)))THEN POS_TO_EXTRACT=I #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ENDIF ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) INODE = NODE_TO_EXTRACT #else INODE = INODE_EFF #endif DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ENDIF #endif 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_820(FLAG_MEM) IF(FLAG_MEM)THEN CALL CMUMPS_561(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_819(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_514(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_509 SUBROUTINE CMUMPS_552(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_275 EXTERNAL MUMPS_275 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_818(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL CMUMPS_818(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_554(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_819(INODE) #if ! defined(NOT_ATM_POOL_SPECIAL) ELSE ENDIF #endif END SUBROUTINE CMUMPS_552 SUBROUTINE CMUMPS_561(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_167 LOGICAL MUMPS_167 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_552(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_553(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_167(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_819(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_561 SUBROUTINE CMUMPS_574 & ( 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_574 SUBROUTINE CMUMPS_128(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, PTRAR, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & ELTNOD, NSLAVES, & XNODEL, NODEL) IMPLICIT NONE INTEGER N,NELT,LIW,IORD, SIZE_SCHUR, NSLAVES INTEGER PTRAR(N,3), NFSIZ(N), FILS(N), FRERE(N) INTEGER ELTPTR(NELT+1) INTEGER XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) INTEGER ELTVAR(ELTPTR(NELT+1)-1) INTEGER IKEEP(N,3) INTEGER LISTVAR_SCHUR(SIZE_SCHUR) INTEGER INFO(40), ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER ELTNOD(NELT) INTEGER K,I,L1,L2,IWFR,NCMPA,LLIW,IFSON,IN INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER NZ, allocok, ITEMP LOGICAL PROK, NOSUPERVAR INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER OPT_METIS_SIZE, NUMFLAG PARAMETER(OPT_METIS_SIZE = 8, NUMFLAG = 1) INTEGER OPTIONS_METIS(OPT_METIS_SIZE) INTEGER IDUM EXTERNAL MUMPS_197, CMUMPS_130, CMUMPS_131, & CMUMPS_129, CMUMPS_132, & CMUMPS_133, CMUMPS_134, & CMUMPS_199, & CMUMPS_557, CMUMPS_201 #if defined(OLDDFS) EXTERNAL CMUMPS_200 #endif ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW RETURN ENDIF MPRINT= ICNTL(3) PROK = (MPRINT.GT.0) LP = ICNTL(1) MP = ICNTL(3) 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) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) 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) IF ( IORD == 5 ) THEN IF (LIW .LT. N+N+1) THEN INFO(1)= -2002 INFO(2) = LIW RETURN ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2*N ) THEN INFO(1)= -2002 INFO(2) = LIW RETURN END IF ELSE IF ( LIW .LT. 4*N+4 ) THEN INFO(1)= -2002 INFO(2) = LIW RETURN END IF ENDIF #if defined(metis) || defined(parmetis) ENDIF #endif IDUM=0 CALL CMUMPS_258(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_129(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), IW(L1)) ELSE CALL CMUMPS_130(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), 4*N+4, IW(L1)) ENDIF LLIW = max(NZ,N) ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF IF (NOSUPERVAR) THEN CALL CMUMPS_132(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) ELSE CALL CMUMPS_131(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_162(N, LLIW, PTRAR, IWFR, PTRAR(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), PTRAR(1,3), & 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_128",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_23(N, LLIW, PTRAR, IWFR, PTRAR(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), PTRAR(1,3)) ENDIF ELSE #if defined(metis) || defined(parmetis) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS ' ENDIF CALL CMUMPS_129(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), IW(L1)) LLIW = max(NZ,N) ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF CALL CMUMPS_538(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, IW(L2), PTRAR(1,2), & IW(L1), IWFR) OPTIONS_METIS(1) = 0 CALL METIS_NODEND(N, IW(L2), IW2(1), NUMFLAG, OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) 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_133(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, PTRAR(1,2), IW(L1)) LLIW = NZ+N ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF CALL CMUMPS_134(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) 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_128",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL CMUMPS_199(N, PTRAR, IW2, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP) ENDIF #if defined(OLDDFS) CALL CMUMPS_200(N, PTRAR, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else CALL CMUMPS_557(N, PTRAR, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, PTRAR(1,2), & INFO(6), FILS, FRERE, PTRAR(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_201(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_209( 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_510(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 IF ( huge(KEEP8(79)) / K79REF + 1_8 .GE. int(NSLAVES,8) ) THEN KEEP8(79)=huge(KEEP8(79)) ELSE KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF ENDIF IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN CALL CMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0) .AND. (NSLAVES.GE.ICNTL(13))) IF (SPLITROOT) THEN CALL CMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) RETURN 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 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) 90 CONTINUE DEALLOCATE(IW) 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_128 SUBROUTINE CMUMPS_258( 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_258 ***') END SUBROUTINE CMUMPS_258 SUBROUTINE CMUMPS_129(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD, 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 DO I = 1,N NZ = NZ + LEN(I) ENDDO RETURN END SUBROUTINE CMUMPS_129 SUBROUTINE CMUMPS_538(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER LEN(N) INTEGER IPE(N+1) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1 DO I = 1,N IWFR = IWFR + LEN(I) 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_538 SUBROUTINE CMUMPS_132(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER LEN(N) INTEGER IPE(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 DO I = 1,N IWFR = IWFR + LEN(I) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0 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 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_132 SUBROUTINE CMUMPS_133(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD 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 DO I = 1,N NZ = NZ + LEN(I) ENDDO RETURN END SUBROUTINE CMUMPS_133 SUBROUTINE CMUMPS_134(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER IPE(N), LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0 DO I = 1,N IWFR = IWFR + LEN(I) + 1 IPE(I) = IWFR ENDDO IWFR = IWFR + 1 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 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = IPE(I) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0 ENDDO RETURN END SUBROUTINE CMUMPS_134 SUBROUTINE CMUMPS_25( 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 PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 INTEGER ELT, I, K, IPTRI, IPTRR, NVAR INTEGER TYPE_PARALL, ITYPE, IRANK TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_330( PROCNODE(abs(STEP(I))), SLAVEF ) IRANK = MUMPS_275( 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 IPTRI = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI IPTRI = IPTRI + NVAR ENDDO PTRAIW( NELT+1 ) = IPTRI KEEP( 14 ) = IPTRI - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + NVAR*NVAR ENDDO PTRARW( NELT+1 ) = IPTRR ELSE IPTRR = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + (NVAR*(NVAR+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR = 1 DO ELT = 1,NELT NVAR = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + NVAR*NVAR ENDDO PTRARW( NELT+1 ) = IPTRR ELSE IPTRR = 1 DO ELT = 1,NELT NVAR = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + (NVAR*(NVAR+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR ENDIF ENDIF KEEP( 13 ) = IPTRR - 1 RETURN END SUBROUTINE CMUMPS_25 SUBROUTINE CMUMPS_120( N, NELT, ELTPROC, SLAVEF, PROCNODE ) IMPLICIT NONE INTEGER N, NELT, SLAVEF INTEGER PROCNODE( N ), ELTPROC( NELT ) INTEGER ELT, I, ITYPE, MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_330(PROCNODE(I),SLAVEF) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_275(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_120 SUBROUTINE CMUMPS_153(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER FRERE(N), FILS(N), NA(N), NE(N) INTEGER FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER XNODEL(N+1), NODEL(NELNOD) INTEGER TNSTK( N ), IPOOL( N ) INTEGER I, K, IFATH INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN 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 file CMUMPS_153 ' 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 RETURN END SUBROUTINE CMUMPS_153 SUBROUTINE CMUMPS_130(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW 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_315 LP = 6 CALL CMUMPS_315(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_315. 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 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 + LEN(I) ENDDO RETURN END SUBROUTINE CMUMPS_130 SUBROUTINE CMUMPS_131(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER IPE(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + LEN(I) IPE(I) = IWFR ELSE IPE(I) = 0 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_131 SUBROUTINE CMUMPS_315(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_316 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_316(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_315: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I8) END SUBROUTINE CMUMPS_315 SUBROUTINE CMUMPS_316( 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_316 SUBROUTINE CMUMPS_36( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & & NSTK_S,NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER NELT,N,LIW,NSTEPS INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER IFLAG,IERROR,INODE,MAXFRW, & IWPOS, IWPOSCB, COMP INTEGER IDUMMY(1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(NELT+1), PTRAIW(NELT+1), ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER INTARR(max(1,KEEP(14))) COMPLEX DBLARR(max(1,KEEP(13))) 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 INCLUDE 'mumps_headers.h' LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER MUMPS_330 EXTERNAL MUMPS_330 INTEGER LP, HS, HF INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) NFRONT8 INTEGER(8) LAELL8, APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) LSTK8, SIZFR8 #if defined(ALLOW_NON_INIT) INTEGER(8) :: JJ8 #endif INTEGER NBPANELS_L, NBPANELS_U, LREQ_OOC INTEGER SIZFI, NCB INTEGER JJ,J1,J2 INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM,JJ1,J3, & IORG, IBROT INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER AINPUT, & AII, 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, SIZE_ELTI INTEGER II, I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) LOGICAL MUMPS_167, SSARBR EXTERNAL MUMPS_167 DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_170 LOGICAL MUMPS_170 NFS4FATHER = -1 ETATASS = 0 COMPRESSCB=.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (LEVEL.NE.1) THEN write(6,*) 'Error1 in mpi51f_niv1 ' 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 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG LREQ_OOC = 0 IF (KEEP(201).EQ.1) THEN CALL CMUMPS_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' 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. IF (KEEP(50).EQ.0) THEN CALL MUMPS_124( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, NFRONT, NFRONT_EFF, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG ) ELSE CALL MUMPS_125( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IF (IFLAG.LT.0) GOTO 300 END IF IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_170(PROCNODE_STEPS(STEP(INODE)), & SLAVEF))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL CMUMPS_190(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 Write(*,*) ' ERROR 1 during ass_niv1_ELT' GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL CMUMPS_691(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_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL CMUMPS_471(SSARBR,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, & LRLU) #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, int(NFRONT -1,8) A(APOS:APOS+JJ8) = ZERO APOS = APOS + NFRONT8 END DO END IF #endif NASS = NASS1 PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST_S(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 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)) LSTK = IW(ISTCHK+KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = IW(ISTCHK + 1+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.LE.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB = & ( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = IW( ISTCHK + 2+KEEP(IXSZ)) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS J1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1) THEN J2 = J1 + 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 J2 = J1 + NELIM - 1 ENDIF OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (J2.GE.J1) THEN DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * NFRONT8 DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 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(J2 - J1 + 1,8) ENDIF CALL CMUMPS_178(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), J2 - J1 + 1, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) END DO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) END DO IF (NELIM .NE. 0) THEN J3 = J3 - 1 DO JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) END DO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP( ISON )) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL CMUMPS_152(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_49( & 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_210( 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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP,KEEP8, 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 & ) IF ( IFLAG .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_71( 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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = INTARR(II) IF (KEEP(50).EQ.0) THEN AINPUT = AII + II - J1 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ=J1,J2 APOS2 = ICT12 + int(INTARR(JJ) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ=II,J2 J = INTARR(JJ) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII) AII = AII + 1 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 JJ=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ELSE DO JJ=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+JJ-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF GOTO 500 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_36' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING CMUMPS_36' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8-LRLUS, IERROR) GOTO 500 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING CMUMPS_36' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = 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 DURING CMUMPS_36' ENDIF IFLAG = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING CMUMPS_36' ENDIF IFLAG = -13 IERROR = NUMSTK 490 CALL CMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_36 SUBROUTINE CMUMPS_37( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, & MEM_DISTRIB) USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER NELT, N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER(8) LRLU, IPTRLU, LRLUS, POSFAC, LA INTEGER(8) LAELL8 INTEGER JJ INTEGER IFLAG,IERROR,INODE,MAXFRW, & LPOOL, LEAF, & IWPOS, & IWPOSCB, COMP, SLAVEF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(NELT+1), PTRAIW(NELT+1), ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), STEP(N), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PAMASTER(KEEP(28)), & PTRAST(KEEP(28)) 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) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER INTARR(max(1,KEEP(14))) COMPLEX DBLARR(max(1,KEEP(13))) INTEGER MYID, COMM INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF, HF_OLD, NSLAVES_OLD,NCBSON INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC, NBPANELS_L, NBPANELS_U INTEGER NCB INTEGER J1,J2 INTEGER(8) NFRONT8, LAPOS2, POSELT, POSEL1, LDAFS8, & JJ2, IACHK, ICT12, ICT21 #if defined(ALLOW_NON_INIT) INTEGER(8) :: JJ8 #endif INTEGER(8) APOS, APOS2 INTEGER NELIM,LDAFS,JJ1,NPIVS,NCOLS,NROWS, & IORG INTEGER LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER AINPUT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, ISLAVE, PDEST INTEGER ELTI, SIZE_ELTI INTEGER II, ELBEG, NUMELT, I, J, AII LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX logical :: force_cand INTEGER(8) APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NUMORG_SPLIT, TYPESPLIT, & NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER IZERO INTEGER IDUMMY(1) INTEGER PDEST1(1) INTEGER ETATASS PARAMETER( IZERO = 0 ) INTEGER MUMPS_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 INTRINSIC real COMPLEX ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = (0.0E0,0.0E0) ) 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) END DO 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_330(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) END IF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO 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 IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) SIZE_TMP_SLAVES_LIST = CAND( SLAVEF+1, INIV2 ) ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_810 (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 265 ENDIF CALL CMUMPS_791 ( & 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_472( 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_790 ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) TMP_SLAVES_LIST (1:SIZE_TMP_SLAVES_LIST) & = CAND (1:SIZE_TMP_SLAVES_LIST, INIV2) CALL CMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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_472( 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_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. IF (KEEP(50).EQ.0) THEN CALL MUMPS_124( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, NFRONT,NFRONT_EFF, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) ELSE CALL MUMPS_125( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IF (IFLAG.LT.0) GOTO 250 ENDIF IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN 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 WRITE(6,*) ' Internal error 2 in fac_ass_elt due', & ' to plitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF CALL MUMPS_ABORT() ELSE CALL CMUMPS_472( 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 JJ=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+JJ)=IW(IOLDPS+HF_OLD+JJ) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO JJ=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+JJ) = IW(IOLDPS+HF_OLD+JJ) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE Write(*,*) ' ERROR 2 during ass_niv2' GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL CMUMPS_691(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST_S(STEP(INODE)) = IOLDPS 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+KEEP(IXSZ)) = NFRONT 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_461(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_533(SLAVEF,CAND(SLAVEF+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_533(SLAVEF,SLAVEF-1, & 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) THEN IF(KEEP(50) .EQ. 2) LAELL8 = LAELL8+int(NASS1,8) ENDIF LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE CALL CMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 CALL CMUMPS_471(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, &LRLU) POSEL1 = POSELT - LDAFS8 #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, LDAFS8 - 1_8 A(APOS:APOS+JJ8) = ZERO APOS = APOS + LDAFS8 END DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN A(APOS:APOS+LDAFS8-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.LE.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) J1 = ISTCHK + HS + NROWS + NPIVS J2 = J1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) IF (KEEP(50).eq.0) THEN DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * LDAFS8 DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1,8) - 1_8) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE 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 CALL CMUMPS_178(A, LA, & POSELT, LDAFS, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), NELIM, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) 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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = INTARR(II) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT = AII + II - J1 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ=J1,J2 APOS2 = ICT12 + int(INTARR(JJ) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI 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) THEN IF (KEEP(50).EQ.2) THEN AINPUT=AII DO JJ=II,J2 J=INTARR(JJ) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))=cmplx( & max(real(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT))), & kind=kind(A) & ) ENDIF AINPUT=AINPUT+1 ENDDO ELSE AII = AII + J2 - II + 1 CYCLE ENDIF ELSE AII = AII + J2 - II + 1 CYCLE ENDIF ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ=II,J2 J = INTARR(JJ) 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(AII) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII))) ENDIF AII = AII + 1 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 JJ = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-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) DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & 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_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & IW(PDEST), NFRONT, COMM, IERR) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL CMUMPS_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & IW(PDEST), NFRONT, COMM, IERR) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.) IF ( IFLAG .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST_S(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF END DO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 END DO 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.LE.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_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) IF (PDEST1(1).EQ.MYID) THEN CALL CMUMPS_211( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8, 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 ) IF ( IFLAG .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL CMUMPS_71( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST_S(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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_49( & 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_210( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, 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 & ) IF ( IFLAG .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_71( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST_S(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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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)) END DO GOTO 500 250 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION during assembly' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 GOTO 490 265 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DYNAMIC ALLOCATION during assembly' ENDIF IFLAG = -13 IERROR = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_37' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, WORKSPACE TOO SMALL DURING CMUMPS_37' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8 - LRLUS, IERROR) 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_37' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = 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_37' ENDIF IFLAG = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SENDBUFFER TOO SMALL (2) DURING CMUMPS_37' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECVBUFFER TOO SMALL (2) DURING CMUMPS_37' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 490 CALL CMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_37 SUBROUTINE CMUMPS_123( & 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), PTRARW(NELT+1), & PTRAIW(NELT+1) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) COMPLEX A(LA), & DBLARR(max(1,KEEP(13))) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSELT, APOS2, ICT12, APOS INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,I,J,JPOS,NASS,JJ, & IN,AINPUT,J1,J2,IJROW,ILOC, & ELBEG, NUMELT, ELTI, SIZE_ELTI, IPOS, & IPOS1, IPOS2, AII, II, IELL INTEGER :: K1RHS, K2RHS, JFirstRHS 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 A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = & ZERO 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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = ITLOC(INTARR(II)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT = AII + II - J1 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ = J1, J2 JPOS = ITLOC(INTARR(JJ)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI END DO ELSE IF ( I .EQ. 0 ) THEN AII = AII + J2 - II + 1 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 JJ=II,J2 AII = AII + 1 J = ITLOC(INTARR(JJ)) 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(AII-1) 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(AII-1) 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 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_123 SUBROUTINE CMUMPS_126( & N, NELT, NA_ELT, & COMM, MYID, SLAVEF, & IELPTR_LOC, RELPTR_LOC, & ELTVAR_LOC, ELTVAL_LOC, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NELT, NA_ELT 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 IELPTR_LOC( NELT + 1 ), RELPTR_LOC( NELT + 1 ) INTEGER ELTVAR_LOC( max(1,KEEP(14)) ) COMPLEX ELTVAL_LOC( max(1,KEEP(13)) ) COMPLEX A( LA ) TYPE(CMUMPS_STRUC) :: id TYPE(CMUMPS_ROOT_STRUC) :: root INTEGER numroc EXTERNAL numroc INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR_MPI INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER RECV_IELTPTR, RECV_RELTPTR INTEGER IELTPTR, RELTPTR, INODE 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, K, NB_REC, IREC INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER IVALPTR 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, DIMENSION( : ), ALLOCATABLE :: ELROOTPOS 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 ) 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 = min(KEEP(39),NA_ELT) 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( ELROOTPOS( 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_276( 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_IELTPTR = 1 RECV_RELTPTR = 1 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR = 1 RELPTR_LOC(1) = 1 DO IEL = 1, NELT IELTPTR = id%ELTPTR( IEL ) SIZEI = id%ELTPTR( IEL + 1 ) - IELTPTR 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 ELROOTPOS( NBELROOT ) = RELTPTR GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL CMUMPS_288( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR ), id%A_ELT( RELTPTR ), & 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_IELTPTR: RECV_IELTPTR + SIZEI - 1 ) & = id%ELTVAR( IELTPTR: IELTPTR + SIZEI - 1 ) RECV_IELTPTR = RECV_IELTPTR + SIZEI IF ( KEEP(52) .ne. 0 ) THEN ELTVAL_LOC( RECV_RELTPTR: RECV_RELTPTR + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR = RECV_RELTPTR + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL CMUMPS_127( & id%ELTVAR(IELTPTR), & id%A_ELT (RELTPTR), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL CMUMPS_127( & id%ELTVAR(IELTPTR), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR = RELTPTR + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC( IEL + 1 ) = RELTPTR ELSE RELPTR_LOC( IEL + 1 ) = RECV_RELTPTR ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP(13) = RELTPTR - 1 ELSE KEEP(13) = RECV_RELTPTR - 1 ENDIF IF ( RELTPTR - 1 .ne. id%NA_ELT ) THEN WRITE(*,*) ' ** ERROR ELT DIST: RELPTR - 1 / id%NA_ELT=', & RELTPTR - 1,id%NA_ELT CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR = 1 RELTPTR = 1 SIZEI = 1 SIZER = 1 CALL CMUMPS_127( & id%ELTVAR(IELTPTR), & id%A_ELT (RELTPTR), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR .eq. IELPTR_LOC( NELT+1 ) & .and. RECV_RELTPTR .eq. RELPTR_LOC( 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_IELTPTR ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR = RECV_IELTPTR + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_COMPLEX, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR ), MSGLEN, & MPI_COMPLEX, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR = RECV_RELTPTR + MSGLEN END SELECT FINI = ( RECV_IELTPTR .eq. IELPTR_LOC( NELT+1 ) & .and. RECV_RELTPTR .eq. RELPTR_LOC( 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_276( 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 IVALPTR = ELROOTPOS( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K = 1 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( IVALPTR + K ) ELSE VAL = id%A_ELT( IVALPTR + K ) * & 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_34( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) END IF K = K + 1 END DO END DO END DO CALL CMUMPS_18( & 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(ELROOTPOS) IF (KEEP(46) .eq. 0 ) THEN DEALLOCATE(RG2LALLOC) ENDIF ENDIF DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE CMUMPS_126 SUBROUTINE CMUMPS_127( & 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_127 SUBROUTINE CMUMPS_213( 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_213 SUBROUTINE CMUMPS_288( 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_288 SUBROUTINE CMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, ICNTL, CNTL, & NZ, IRN, IRNhere, JCN, JCNhere, A, Ahere, & NZ_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 ICNTL(40), INFO(40), INFOG(40) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN REAL CNTL(15), RINFO(40), RINFOG(40) 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(in) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(in) :: 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 CMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (CMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_AFFECT_MAPPING, & MUMPS_AFFECT_PIVNUL_LIST, & MUMPS_AFFECT_SYM_PERM, & MUMPS_AFFECT_UNS_PERM 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%NZ_loc = NZ_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%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) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NZ) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NZ) IF ( Ahere /= 0 ) mumps_par%A => A(1:NZ) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NZ_loc) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NZ_loc) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NZ_loc) 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) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NZ = mumps_par%NZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_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_AFFECT_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_AFFECT_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_AFFECT_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_AFFECT_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF 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-4.10.0.dfsg/src/mumps_common.h0000644000175300017530000001045111562233011017545 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #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_AFFECT_MAPPING \ F_SYMBOL(affect_mapping,AFFECT_MAPPING) void MUMPS_CALL MUMPS_AFFECT_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_AFFECT_PIVNUL_LIST \ F_SYMBOL(affect_pivnul_list,AFFECT_PIVNUL_LIST) void MUMPS_CALL MUMPS_AFFECT_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_AFFECT_UNS_PERM \ F_SYMBOL(affect_uns_perm,AFFECT_UNS_PERM) void MUMPS_CALL MUMPS_AFFECT_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_AFFECT_SYM_PERM \ F_SYMBOL(affect_sym_perm,AFFECT_SYM_PERM) void MUMPS_CALL MUMPS_AFFECT_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-4.10.0.dfsg/src/mumps_part9.F0000644000175300017530000100757111562233013017266 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C C $Id$ SUBROUTINE MUMPS_419 (METRIC, JOB, COMPRESS, N, NBBUCK, & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, & WF, & NEXT, W, HEAD, AGG4, & SIZE_COMPLEM_LIST, & COMPLEM_LIST) IMPLICIT NONE INTEGER, intent(in) :: METRIC, JOB, N, NBBUCK LOGICAL, intent(in) :: COMPRESS INTEGER IWLEN, PFREE, LEN(N), & ELEN(N), LAST(N), NCMPA, DEGREE(N), NEXT(N), & W(N) INTEGER PE(N), IW(IWLEN), NV(N) LOGICAL, intent(in) :: AGG4 INTEGER, intent(in) :: SIZE_COMPLEM_LIST INTEGER, intent(in), optional :: & COMPLEM_LIST(max(1,SIZE_COMPLEM_LIST)) INTEGER HEAD(0:NBBUCK+1), WF(N) INTEGER AMD, AMF1, AMF4MA41 PARAMETER (AMD=1, AMF1=2, AMF4MA41=4) INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & LASTD, NELME, N2, PAS INTEGER MAXINT_N INTEGER WF3, WF4 INTEGER(8) HASH, HMOD DOUBLE PRECISION RMF, RMF1 DOUBLE PRECISION dummy INTEGER idummy LOGICAL SchurON LOGICAL NOTDEFINEDAMD INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC INTRINSIC max, min, mod, huge INTEGER TOTEL NOTDEFINEDAMD = (METRIC.NE.AMD) IF (N.EQ.1) THEN ELEN(1) = 1 LAST(1) = 1 PE(1) = 0 NV(1) = 1 RETURN ENDIF IF (.NOT.present(COMPLEM_LIST)) SchurON=.FALSE. IF ( SIZE_COMPLEM_LIST < 0 .OR. SIZE_COMPLEM_LIST > N ) THEN WRITE(*,*) 'Internal MUMPS_419 ', SIZE_COMPLEM_LIST,N CALL MUMPS_ABORT() ENDIF IF (JOB.EQ.2) THEN SchurON = .FALSE. ENDIF IF (JOB.NE.2) THEN SchurON = (SIZE_COMPLEM_LIST > 0) IF ((JOB.EQ.1) .AND. (.NOT.SchurON) ) THEN WRITE(6,*) ' WARNING MUMPS_419 on Options ', JOB ENDIF ENDIF idummy = huge(idummy) - 1 dummy = dble(idummy) N2 = -NBBUCK-1 PAS = max((N/8), 1) WFLG = 2 MAXINT_N = huge(MAXINT_N) - N NCMPA = 0 NEL = 0 HMOD = int(max (1, NBBUCK-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM MINDEG = 0 LASTD = 0 HEAD(0:NBBUCK+1) = 0 DEGREE(1:N) = LEN(1:N) LAST = 0 W(1:N) = 1 TOTEL = N IF (.NOT.COMPRESS) THEN NV = 1 ENDIF IF (JOB.EQ.2) THEN DO I = 1,SIZE_COMPLEM_LIST X = COMPLEM_LIST(I) ELEN(X) = -I NV(X) = LEN(X)+1 ENDDO NEL = NEL + SIZE_COMPLEM_LIST ELSE ELEN(1:N) = 0 DO K=1, SIZE_COMPLEM_LIST I = COMPLEM_LIST(K) DEGREE(I) = N2 IF ((LEN(I) .EQ.0).OR.(LEN(I).EQ.-N-1)) THEN PE (I) = 0 LEN(I) = 0 ENDIF DEG = NBBUCK + 1 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 ENDDO ENDIF IF(COMPRESS) THEN TOTEL = 0 DO I=1,N IF (ELEN(I).LT.0) CYCLE IF (DEGREE(I).NE.N2) THEN TOTEL = TOTEL + NV(I) DEGREE(I) = ELEN(I) DO J= PE(I)+ELEN(I), PE(I)+LEN(I)-1 DEGREE(I) = DEGREE(I) + NV(IW(J)) ENDDO ENDIF ENDDO ENDIF RMF = dble(0) DO I = 1, N IF (ELEN(I).LT.0) CYCLE DEG = DEGREE (I) IF (DEG.EQ.N2) CYCLE IF (DEG .GT. 0) THEN IF (JOB.EQ.2) THEN DEG = DEG - ELEN(I) NVI = NV(I) RMF = dble(0) IF (ELEN(I).GT.0) THEN DO J= PE(I), PE(I)+ELEN(I)-1 DEG = DEG + LEN(IW(J)) - NVI IF (NOTDEFINEDAMD) THEN RMF1 = dble( LEN(IW(J))) RMF1 = (RMF1-dble(NVI))*(RMF1-dble(NVI)-1.0D0) RMF = max(RMF, RMF1) ENDIF ENDDO DEG = min(DEG, TOTEL-NEL-NV(I)) ENDIF ENDIF IF ( & ( (JOB.EQ.2).AND.NOTDEFINEDAMD) & .OR. (METRIC.EQ.AMF4MA41) & ) THEN DEG = nint ( & ( (dble(DEG)*dble(DEG-1)) - RMF ) / dble(2) ) DEG = max (DEG,1) ENDIF IF (NOTDEFINEDAMD) THEN WF(I) = DEG IF (DEG.GT.N) THEN DEG = min(((DEG-N)/PAS) + N , NBBUCK) ENDIF ELSE DEGREE(I) = DEG ENDIF INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0 W (I) = 0 ENDIF ENDDO NLEFT = TOTEL-NEL 30 IF ( ((NEL .LT. TOTEL).AND. (JOB.NE.1)) .OR. & ((JOB.EQ.1).AND.(NEL.LT.TOTEL-SIZE_COMPLEM_LIST)) & ) THEN 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 IF (NOTDEFINEDAMD) THEN J = NEXT(ME) K = WF(ME) 55 CONTINUE IF (J.GT.0) THEN IF (WF(J).LT.K) THEN ME = J K = WF(ME) ENDIF J= NEXT(J) GOTO 55 ENDIF ILAST = LAST(ME) INEXT = NEXT(ME) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (DEG) = INEXT ENDIF ELSE WRITE(6,*) ' Internal error AMD, DEG>N ' CALL MUMPS_ABORT() ENDIF ELSE INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ENDIF ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN 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 DEGME = DEGME + NVI NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I IF (DEGREE(I).NE.N2) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE IF (NOTDEFINEDAMD) THEN IF (WF(I).GT.N) THEN DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) ELSE DEG = WF(I) ENDIF HEAD (DEG) = INEXT ELSE HEAD (DEGREE (I)) = INEXT ENDIF ENDIF ENDIF ENDIF 60 CONTINUE NEWMEM = 0 ELSE P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME DO 120 KNT1 = 1, ELENME + 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 DO 110 KNT2 = 1, LN 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 IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2 IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = IW (PN) 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) = PE (J) PE (J) = PDST PDST = PDST + 1 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 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).NE.N2) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE IF (NOTDEFINEDAMD) THEN IF (WF(I).GT.N) THEN DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) ELSE DEG = WF(I) ENDIF HEAD (DEG) = INEXT ELSE HEAD(DEGREE(I)) = INEXT ENDIF ENDIF ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN PE (E) = -ME 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) = PME2 - PME1 + 1 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).EQ.N2) GOTO 150 ELN = ELEN (I) IF (ELN .GT. 0) THEN 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 WE = WE - NVI ELSE IF (WE .NE. 0) THEN WE = DEGREE (E) + WNVI IF (NOTDEFINEDAMD) WF(E) = 0 ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE DO 180 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).EQ.N2) GOTO 180 P1 = PE (I) P2 = P1 + ELEN (I) - 1 PN = P1 HASH = 0_8 DEG = 0 IF (NOTDEFINEDAMD) THEN WF3 = 0 WF4 = 0 ENDIF NVI = -NV(I) DO 160 P = P1, P2 E = IW (P) DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN IF (NOTDEFINEDAMD) THEN IF ( WF(E) .EQ. 0 ) THEN WF(E) = DEXT * ( (2 * DEGREE(E)) - DEXT - 1) ENDIF WF4 = WF4 + WF(E) ENDIF DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E, kind=8) ELSE IF (DEXT .EQ. 0) THEN IF (.NOT.AGG4) THEN IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE PE (E) = -ME W (E) = 0 ENDIF ENDIF 160 CONTINUE ELEN (I) = PN - P1 + 1 P3 = PN DO 170 P = P2 + 1, P1 + LEN (I) - 1 J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN DEG = DEG + NVJ IF (NOTDEFINEDAMD) WF3 = WF3 + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE IF (DEGREE(I).EQ.N2) DEG = N2 IF ( (AGG4.AND.(DEG .EQ. 0)).OR. & (ELEN(I).EQ.1 .AND. P3.EQ.PN) ) THEN PE (I) = -ME NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE IF ( DEGREE (I).LT.DEG ) THEN IF (NOTDEFINEDAMD) THEN WF4 = 0 WF3 = 0 ENDIF ELSE DEGREE(I) = DEG ENDIF IF (NOTDEFINEDAMD) THEN WF(I) = WF4 + 2*NVI*WF3 ENDIF IW (PN) = IW (P3) IW (P3) = IW (P1) IW (P1) = ME LEN (I) = 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).NE.N2) ) 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 LN = LEN (I) ELN = ELEN (I) DO 210 P = PE (I) + 1, PE (I) + LN - 1 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) + LN - 1 IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE PE (J) = -I IF (NOTDEFINEDAMD) WF(I) = max(WF(I),WF(J)) NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 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 P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN NV (I) = NVI IF (DEGREE(I).NE.N2) THEN DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) IF (NOTDEFINEDAMD) THEN IF(METRIC.EQ.AMF1) THEN DEGREE(I) = DEG RMF = dble(DEG)*dble(DEG-1) & - dble(DEGME-NVI)*dble(DEGME-NVI-1) ELSE IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN 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 ENDIF IF (METRIC.EQ.AMF4MA41) THEN RMF = RMF / dble(2*NVI) ELSE RMF = RMF / dble(NVI+1) ENDIF 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 ELSE DEGREE(I) = DEG ENDIF INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I MINDEG = min (MINDEG, DEG) ENDIF IW (P) = I P = P + 1 ENDIF 260 CONTINUE NV (ME) = NVPIV + DEGME LEN (ME) = P - PME1 IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF GO TO 30 ENDIF IF (NEL.LT.TOTEL) THEN 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 ENDDO NEL = NEL+ SIZE_COMPLEM_LIST ELSE 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 PE(X) = -ME ELSEIF (DEGREE(X).EQ.N2) THEN NEL = NEL + NV(X) PE(X) = -ME ELEN(X) = 0 NV(X) = 0 ENDIF ENDDO ELEN(ME) = NELME NV(ME) = SIZE_COMPLEM_LIST PE(ME) = 0 ENDIF IF (NEL.NE.N) THEN write(*,*) ' Error 2 in HALO AMD NEL, N=', NEL,N NCMPA = -N - 1 CALL MUMPS_ABORT() ENDIF ENDIF DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = -PE (I) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = -PE (J) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = -PE (J) PE (J) = -E 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 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 PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_419 SUBROUTINE MUMPS_197(N, IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W) INTEGER N, IWLEN, PFREE, NCMPA INTEGER NEXT(N), LEN(N), & ELEN(N), LAST(N), DEGREE(N), HEAD(N), & W(N) INTEGER IW(IWLEN), NV(N), PE(N) INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER MAXINT_N INTEGER(8) HASH, HMOD INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC INTRINSIC max, min, mod 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 DO 20 I = 1, N DEG = DEGREE (I) IF (DEG .GT. 0) THEN INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE NEL = NEL + 1 ELEN (I) = -NEL PE (I) = 0 W (I) = 0 ENDIF 20 CONTINUE 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 INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN 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 DEGME = DEGME + NVI NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 60 CONTINUE NEWMEM = 0 ELSE P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME DO 120 KNT1 = 1, ELENME + 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 DO 110 KNT2 = 1, LN 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 IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2 IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = IW (PN) 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) = PE (J) PE (J) = PDST PDST = PDST + 1 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 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 ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN PE (E) = -ME 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) = PME2 - PME1 + 1 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) ELN = ELEN (I) IF (ELN .GT. 0) THEN 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 WE = WE - NVI ELSE IF (WE .NE. 0) THEN WE = DEGREE (E) + WNVI ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE DO 180 PME = PME1, PME2 I = IW (PME) 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 (DEXT .EQ. 0) THEN #if defined (NOAGG1) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else PE (E) = -ME W (E) = 0 #endif ENDIF 160 CONTINUE ELEN (I) = PN - P1 + 1 P3 = PN DO 170 P = P2 + 1, P1 + LEN (I) - 1 J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN DEG = DEG + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE #if defined (NOAGG1) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif PE (I) = -ME NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE DEGREE (I) = min (DEGREE (I), DEG) IW (PN) = IW (P3) IW (P3) = IW (P1) IW (P1) = ME LEN (I) = 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) 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 LN = LEN (I) ELN = ELEN (I) DO 210 P = PE (I) + 1, PE (I) + LN - 1 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) + LN - 1 IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE PE (J) = -I NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 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 P = PME1 NLEFT = N - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN NV (I) = NVI DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I MINDEG = min (MINDEG, DEG) DEGREE (I) = DEG IW (P) = I P = P + 1 ENDIF 260 CONTINUE NV (ME) = NVPIV + DEGME LEN (ME) = P - PME1 IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF GO TO 30 ENDIF DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = -PE (I) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = -PE (J) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = -PE (J) PE (J) = -E 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 PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_197 SUBROUTINE MUMPS_23(N,IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W) INTEGER N, IWLEN, PFREE, NCMPA INTEGER PE(N), LEN(N), & ELEN(N), LAST(N), DEGREE(N), HEAD(N), & W(N) INTEGER IW(IWLEN), NV(N), NEXT(N) INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NPRINC INTEGER MAXINT_N INTEGER(8) HASH, HMOD INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC INTRINSIC max, min, mod 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 J = -LEN (I) DEGREE (I) = - 1 IF ( PE(I) .NE. 0 ) THEN LEN (I) = LEN(J) ELSE LEN (I) = 0 ENDIF PE (I) = -J NV (J) = NV (J) + NV (I) NV (I) = 0 ELEN (I) = 0 ENDIF ENDDO DO 20 I = 1, N DEG = DEGREE (I) IF (DEG .GT. 0) THEN INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE IF ( DEG.EQ. 0) THEN ELEN (I) = - (NEL + 1) NEL = NEL + NV(I) PE (I) = 0 W (I) = 0 ENDIF 20 CONTINUE 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 INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN 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 DEGME = DEGME + NVI NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 60 CONTINUE NEWMEM = 0 ELSE P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME DO 120 KNT1 = 1, ELENME + 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 DO 110 KNT2 = 1, LN 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 IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2 IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = IW (PN) 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) = PE (J) PE (J) = PDST PDST = PDST + 1 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 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 ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN PE (E) = -ME 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) = PME2 - PME1 + 1 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) ELN = ELEN (I) IF (ELN .GT. 0) THEN 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 WE = WE - NVI ELSE IF (WE .NE. 0) THEN WE = DEGREE (E) + WNVI ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE DO 180 PME = PME1, PME2 I = IW (PME) 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 (DEXT .EQ. 0) THEN #if defined (NOAGG2) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else PE (E) = -ME W (E) = 0 #endif ENDIF 160 CONTINUE ELEN (I) = PN - P1 + 1 P3 = PN DO 170 P = P2 + 1, P1 + LEN (I) - 1 J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN DEG = DEG + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE #if defined (NOAGG2) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif PE (I) = -ME NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE DEGREE (I) = min (DEGREE (I), DEG) IW (PN) = IW (P3) IW (P3) = IW (P1) IW (P1) = ME LEN (I) = 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) 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 LN = LEN (I) ELN = ELEN (I) DO 210 P = PE (I) + 1, PE (I) + LN - 1 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) + LN - 1 IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE PE (J) = -I NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 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 P = PME1 NLEFT = N - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN NV (I) = NVI DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I MINDEG = min (MINDEG, DEG) DEGREE (I) = DEG IW (P) = I P = P + 1 ENDIF 260 CONTINUE NV (ME) = NVPIV + DEGME LEN (ME) = P - PME1 IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF GO TO 30 ENDIF DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = -PE (I) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = -PE (J) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = -PE (J) PE (J) = -E 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 PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_23 SUBROUTINE MUMPS_162(N, IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W, & LISTVAR_SCHUR, SIZE_SCHUR) INTEGER SIZE_SCHUR INTEGER LISTVAR_SCHUR(SIZE_SCHUR) INTEGER N, IWLEN, PFREE, NCMPA INTEGER LEN(N), & ELEN(N), LAST(N), DEGREE(N), HEAD(N), & W(N), NEXT(N) INTEGER IW(IWLEN), NV(N), PE(N) INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NBFLAG, NREAL, LASTD, NELME INTEGER MAXINT_N INTEGER(8) HASH, HMOD INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC INTRINSIC max, min, mod 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 NBFLAG = 0 LASTD = 0 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 NBFLAG = SIZE_SCHUR DO K=1,SIZE_SCHUR I = LISTVAR_SCHUR(K) DEGREE(I) = N+1 IF ((LEN(I) .EQ.0).OR.(LEN(I).EQ.-N-1)) THEN PE (I) = 0 LEN(I) = 0 ENDIF 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 ENDDO NREAL = N - NBFLAG DO 20 I = 1, N DEG = DEGREE (I) IF (DEG.EQ.N+1) GOTO 20 IF (DEG .GT. 0) THEN INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE NEL = NEL + 1 ELEN (I) = -NEL PE (I) = 0 W (I) = 0 ENDIF 20 CONTINUE NLEFT = N-NEL 30 IF (NEL .LT. NREAL) THEN DO 40 DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG IF (ME.LE.0) THEN write (*,*) ' Error 1 in HALO_AMD ' NCMPA = -N GOTO 500 ENDIF INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN 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 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 (DEGREE (I)) = INEXT ENDIF ENDIF ENDIF 60 CONTINUE NEWMEM = 0 ELSE P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME DO 120 KNT1 = 1, ELENME + 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 DO 110 KNT2 = 1, LN 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 IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2 IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = IW (PN) 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) = PE (J) PE (J) = PDST PDST = PDST + 1 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 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 (DEGREE (I)) = INEXT ENDIF ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN PE (E) = -ME 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) = PME2 - PME1 + 1 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) ELN = ELEN (I) IF (ELN .GT. 0) THEN 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 WE = WE - NVI ELSE IF (WE .NE. 0) THEN WE = DEGREE (E) + WNVI ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE DO 180 PME = PME1, PME2 I = IW (PME) 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 (DEXT .EQ. 0) THEN #if defined (NOAGG3) IW (PN) = E PN = PN + 1 HASH = HASH + E #else PE (E) = -ME W (E) = 0 #endif ENDIF 160 CONTINUE ELEN (I) = PN - P1 + 1 P3 = PN DO 170 P = P2 + 1, P1 + LEN (I) - 1 J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN DEG = DEG + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE IF (DEGREE(I).EQ.N+1) DEG = N+1 #if defined (NOAGG3) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif PE (I) = -ME NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE IF (DEGREE(I).NE.N+1) THEN DEG = min (DEG, NLEFT) DEGREE (I) = min (DEGREE (I), DEG) ENDIF IW (PN) = IW (P3) IW (P3) = IW (P1) IW (P1) = ME LEN (I) = PN - P1 + 1 IF (DEG.LE.N) THEN 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 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 LN = LEN (I) ELN = ELEN (I) DO 210 P = PE (I) + 1, PE (I) + LN - 1 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) + LN - 1 IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE PE (J) = -I NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 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 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) INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I MINDEG = min (MINDEG, DEG) DEGREE (I) = DEG ENDIF IW (P) = I P = P + 1 ENDIF 260 CONTINUE NV (ME) = NVPIV + DEGME LEN (ME) = P - PME1 IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF GO TO 30 ENDIF IF (NEL.LT.N) THEN DO DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 51 ENDDO 51 MINDEG = DEG IF (ME.NE.LISTVAR_SCHUR(1)) THEN write(6,*) ' error 1 in MUMPS_162 ' write(6,*) ' wrong principal var for Schur !!' NCMPA = -N - 2 CALL MUMPS_ABORT() ENDIF NELME = -(NEL+1) DO X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN PE(X) = -ME ELSEIF (DEGREE(X).EQ.N+1) THEN NEL = NEL + NV(X) PE(X) = -ME ELEN(X) = 0 NV(X) = 0 ENDIF ENDDO ELEN(ME) = NELME NV(ME) = N-NREAL PE(ME) = 0 IF (NEL.NE.N) THEN write(*,*) ' Error 2 in MUMPS_162 NEL, N=', NEL,N NCMPA = -N - 1 CALL MUMPS_ABORT() ENDIF ENDIF DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = -PE (I) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = -PE (J) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = -PE (J) PE (J) = -E 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 500 PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_162 SUBROUTINE MUMPS_337(N, NBBUCK, & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, WF, NEXT, W, HEAD) IMPLICIT NONE INTEGER N, IWLEN, PFREE, LEN(N), & ELEN(N), LAST(N), NCMPA, DEGREE(N), NEXT(N), & W(N) INTEGER PE(N), IW(IWLEN), NV(N) INTEGER NBBUCK INTEGER HEAD(0:NBBUCK+1), WF(N) INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NBFLAG, NREAL, LASTD, NELME, WF3, WF4, N2, PAS INTEGER MAXINT_N INTEGER(8) HASH, HMOD DOUBLE PRECISION RMF, RMF1 DOUBLE PRECISION dummy INTEGER idummy INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC INTRINSIC max, min, mod, huge INTEGER TOTEL LOGICAL COMPRESS idummy = huge(idummy) - 1 dummy = dble(idummy) N2 = -NBBUCK-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 NBFLAG = 0 LASTD = 0 HEAD(0:NBBUCK+1) = 0 DO 10 I = 1, N LAST(I) = 0 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 LEN (I) = 0 PE (I) = 0 ELSE LEN (I) = - LEN(I) ENDIF ELSE TOTEL = TOTEL + NV(I) DEGREE(I) = 0 DO J= PE(I) , PE(I)+LEN(I)-1 DEGREE(I) = DEGREE(I) + NV(IW(J)) ENDDO ENDIF ENDDO ELSE DO I=1,N NV(I) = 1 IF (LEN(I).LT.0) THEN DEGREE (I) = N2 NBFLAG = NBFLAG +1 IF (LEN(I).EQ.-N-1) THEN LEN (I) = 0 PE (I) = 0 ELSE LEN (I) = - LEN(I) ENDIF ELSE DEGREE (I) = LEN (I) ENDIF ENDDO TOTEL = N - NBFLAG ENDIF NREAL = N - NBFLAG DO 20 I = 1, N DEG = DEGREE (I) IF (DEG.EQ.N2) THEN DEG = NBBUCK + 1 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 GOTO 20 ENDIF IF (DEG .GT. 0) THEN WF(I) = DEG 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 HEAD (DEG) = I ELSE NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0 W (I) = 0 ENDIF 20 CONTINUE NLEFT = TOTEL-NEL 30 IF (NEL .LT. TOTEL) THEN 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 J = NEXT(ME) K = WF(ME) 55 CONTINUE IF (J.GT.0) THEN IF (WF(J).LT.K) THEN ME = J K = WF(ME) ENDIF J= NEXT(J) GOTO 55 ENDIF ILAST = LAST(ME) INEXT = NEXT(ME) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (DEG) = INEXT ENDIF ELSE INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ENDIF ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN 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 DEGME = DEGME + NVI NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I IF (DEGREE(I).NE.N2) THEN 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 HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 60 CONTINUE NEWMEM = 0 ELSE P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME DO 120 KNT1 = 1, ELENME + 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 DO 110 KNT2 = 1, LN 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 IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2 IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = IW (PN) 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) = PE (J) PE (J) = PDST PDST = PDST + 1 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 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).NE.N2) THEN 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 HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN PE (E) = -ME 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) = PME2 - PME1 + 1 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) ELN = ELEN (I) IF (ELN .GT. 0) THEN 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 WE = WE - NVI ELSE IF (WE .NE. 0) THEN WE = DEGREE (E) + WNVI WF(E) = 0 ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE 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) DO 160 P = P1, P2 E = IW (P) DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN IF ( WF(E) .EQ. 0 ) THEN 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 PE (E) = -ME W (E) = 0 #endif ENDIF 160 CONTINUE ELEN (I) = PN - P1 + 1 P3 = PN DO 170 P = P2 + 1, P1 + LEN (I) - 1 J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN DEG = DEG + NVJ WF3 = WF3 + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE IF (DEGREE(I).EQ.N2) DEG = N2 #if defined (NOAGG4) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif PE (I) = -ME NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE IF (DEGREE(I).NE.N2) THEN IF ( DEGREE (I).LT.DEG ) THEN WF4 = 0 WF3 = 0 ELSE DEGREE(I) = DEG ENDIF ENDIF WF(I) = WF4 + 2*NVI*WF3 IW (PN) = IW (P3) IW (P3) = IW (P1) IW (P1) = ME LEN (I) = PN - P1 + 1 IF (DEG.NE.N2) THEN 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 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).NE.N2) ) 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 LN = LEN (I) ELN = ELEN (I) DO 210 P = PE (I) + 1, PE (I) + LN - 1 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) + LN - 1 IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE PE (J) = -I WF(I) = max(WF(I),WF(J)) NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 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 P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN NV (I) = NVI IF (DEGREE(I).NE.N2) THEN DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN 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) 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 MINDEG = min (MINDEG, DEG) ENDIF IW (P) = I P = P + 1 ENDIF 260 CONTINUE NV (ME) = NVPIV + DEGME LEN (ME) = P - PME1 IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF GO TO 30 ENDIF IF (NEL.LT.N) THEN 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 PE(X) = -ME ELSEIF (DEGREE(X).EQ.N2) THEN NEL = NEL + NV(X) PE(X) = -ME ELEN(X) = 0 NV(X) = 0 ENDIF ENDDO ELEN(ME) = NELME NV(ME) = N-NREAL PE(ME) = 0 IF (NEL.NE.N) THEN NCMPA = -N - 1 GOTO 500 ENDIF ENDIF DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = -PE (I) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = -PE (J) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = -PE (J) PE (J) = -E 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 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 500 PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_337 SUBROUTINE MUMPS_421 & (TOTEL, IVersion, THRESH, NDENSE, & N, IWLEN, PE, PFREE, LEN, IW, NV, & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W) INTEGER TOTEL INTEGER N, IWLEN, PE(N), PFREE, LEN(N), IW(IWLEN), NV(N), & ELEN(N), NCMPA, DEGREE(N), & LAST(TOTEL), HEAD(TOTEL), NEXT(N), & W(N) INTEGER NDENSE(N) INTEGER IVersion, THRESH INTEGER THRESM, MINDEN, MAXDEN, NDME INTEGER NBD,NBED, NBDM, LASTD, NELME LOGICAL IDENSE DOUBLE PRECISION RELDEN INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER MAXINT_N INTEGER(8) HASH, HMOD INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC INTRINSIC max, min, mod LOGICAL COMPRESS 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) THRESM = int(RELDEN)*10 + (THRESM-int(RELDEN))/10 + 1 ELSE THRESM = TOTEL ENDIF IF (THRESM.GE.0) THEN IF ((THRESM.GT.TOTEL).OR.(THRESM.LT.2)) THEN 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 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 DO I=1,N DEGREE(I) = 0 DO J= PE(I) , PE(I)+LEN(I)-1 DEGREE(I) = DEGREE(I) + NV(IW(J)) ENDDO ENDDO ELSE DO I=1,N NV(I) = 1 DEGREE (I) = LEN (I) ENDDO ENDIF DO 20 I = 1, N DEG = DEGREE (I) IF (DEG .GT. 0) THEN IF ( (THRESM.GE.0) .AND. & (DEG+NV(I).GE.THRESM) ) THEN NBD = NBD+1 IF (DEG+NV(I).NE.TOTEL-NEL) THEN DEGREE(I) = DEGREE(I)+TOTEL+1 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 DEG = TOTEL 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 (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ENDIF ELSE NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0 W (I) = 0 ENDIF 20 CONTINUE IF (NBD.EQ.0) THRESM = TOTEL NLEFT = TOTEL - NEL 30 IF (NEL .LT. TOTEL) THEN 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 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 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 + LEN(ME) -1 LN = P1 ELN = P1 DO 55 P=P1,P2 E= IW(P) IF (W(E).EQ.WFLG) GOTO 55 W(E) = WFLG IF (PE(E).LT.0) THEN X = E 53 X = -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(LN) = IW(ELN) IW(ELN) = E LN = LN+1 ELN = ELN + 1 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(LN)=E LN = LN+1 ENDIF 55 CONTINUE WFLG = WFLG + 1 LEN(ME) = LN-P1 ELEN(ME) = ELN- P1 NDME = NDENSE(ME)+NV(ME) MINDEN = min (MINDEN, NDME) MAXDEN = max (MAXDEN, NDME) IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 IF (IVersion.EQ.1) THEN DEG = max (DEGREE(ME)-(TOTEL+1), 1) ELSE 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 ME = INEXT IF (ME.NE.0) THEN IF (DEGREE(ME).GT.(TOTEL+1) ) GOTO 51 ENDIF HEAD (TOTEL) = ME IF (IVersion .EQ.1 ) THEN THRESM = TOTEL ELSE THRESM=max(THRESM*2,MINDEN+(MAXDEN-MINDEN)/2) THRESM = min(THRESM,NBD) IF (THRESM.GE.NBD) THRESM=TOTEL ENDIF NBD = NBED GOTO 30 ENDIF IF (DEGREE(ME).EQ.TOTEL+1) THEN IF (NBD.NE.NBED) THEN write(6,*) ' Internal ERROR quasi dense rows remains' CALL MUMPS_ABORT() ENDIF NELME = -(NEL+1) DO 59 X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN PE(X) = -ME ELSEIF (DEGREE(X).EQ.TOTEL+1) THEN NEL = NEL + NV(X) PE(X) = -ME ELEN(X) = 0 NV(X) = 0 ENDIF 59 CONTINUE ELEN(ME) = NELME NV(ME) = NBD PE(ME) = 0 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 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 + LEN (ME) - 1 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.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (DEGREE (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 DO 120 KNT1 = 1, ELENME + 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 DO 110 KNT2 = 1, LN 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 IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2 IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = IW (PN) 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) = PE (J) PE (J) = PDST PDST = PDST + 1 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 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.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (DEGREE (I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN PE (E) = -ME 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) = PME2 - PME1 + 1 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.TOTEL) GOTO 150 ELN = ELEN (I) IF (ELN .GT. 0) THEN 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 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.TOTEL) 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) #if defined (NOAGG5) ELSE IF (DEXT .EQ. 0) THEN IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else ELSE IF ((DEXT .EQ. 0) .AND. & (NDENSE(ME).EQ.NBD)) THEN PE (E) = -ME 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 ELEN (I) = PN - P1 + 1 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.TOTEL) DEG=DEG+NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE #if defined (NOAGG5) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF ((DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) THEN #endif PE (I) = -ME 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) = 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.TOTEL) ) 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 LN = LEN (I) ELN = ELEN (I) DO 210 P = PE (I) + 1, PE (I) + LN - 1 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) + LN - 1 IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE PE (J) = -I NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 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 P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN NV (I) = NVI IF (DEGREE(I).LE.TOTEL) THEN DEG = min (DEGREE (I)+ DEGME - NVI, NLEFT - NVI) DEGREE (I) = DEG IDENSE = .FALSE. IF ( (Iversion .NE. 1).AND. (THRESM.GE.0)) THEN IF (DEG+NVI .GE. THRESM) THEN IF (THRESM.EQ.TOTEL) THEN IF ((ELEN(I).LE.2) .AND. ((DEG+NVI).EQ.NLEFT) ) THEN DEGREE(I) = TOTEL+1 IDENSE = .TRUE. ENDIF ELSE 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 P1 = PE(I) P2 = P1 + ELEN(I) - 1 IF (P2.GE.P1) THEN DO 264 PJ=P1,P2 E= IW(PJ) NDENSE (E) = NDENSE(E) + NVI 264 CONTINUE ENDIF NBD = NBD+NVI DEG = TOTEL IF (DEGREE(I).EQ.TOTEL+1) THEN NBED = NBED +NVI 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 ELSE 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 ENDIF IF (.NOT.IDENSE) THEN INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I ENDIF MINDEG = min (MINDEG, DEG) ENDIF IW (P) = I P = P + 1 ENDIF 260 CONTINUE NV (ME) = NVPIV + DEGME LEN (ME) = P - PME1 IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF GO TO 30 ENDIF 265 CONTINUE DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = -PE (I) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = -PE (J) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = -PE (J) PE (J) = -E 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 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 PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_421 SUBROUTINE MUMPS_560(N, NBBUCK, & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, WF, NEXT, W, HEAD, & CONSTRAINT,THESON) IMPLICIT NONE INTEGER N, IWLEN, PFREE, LEN(N), & ELEN(N), LAST(N), NCMPA, DEGREE(N), NEXT(N), & W(N) INTEGER PE(N), IW(IWLEN), NV(N) INTEGER NBBUCK INTEGER HEAD(0:NBBUCK+1), WF(N) INTEGER CONSTRAINT(N),THESON(N) INTEGER PREV,TOTO INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NBFLAG, NREAL, LASTD, NELME, WF3, WF4, N2, PAS INTEGER MAXINT_N INTEGER(8) HASH, HMOD DOUBLE PRECISION RMF, RMF1 DOUBLE PRECISION dummy INTEGER idummy INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC INTRINSIC max, min, mod, huge INTEGER TOTEL idummy = huge(idummy) - 1 dummy = dble(idummy) N2 = -NBBUCK-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 NBFLAG = 0 LASTD = 0 HEAD(0:NBBUCK+1) = 0 DO 10 I = 1, N THESON(I) = 0 LAST (I) = 0 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 LEN (I) = 0 PE (I) = 0 ELSE LEN (I) = - LEN(I) ENDIF ELSE TOTEL = TOTEL + NV(I) DEGREE(I) = 0 DO J= PE(I) , PE(I)+LEN(I)-1 DEGREE(I) = DEGREE(I) + NV(IW(J)) ENDDO ENDIF ENDDO NREAL = N - NBFLAG DO 20 I = 1, N DEG = DEGREE (I) IF (DEG.EQ.N2) THEN DEG = NBBUCK + 1 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 GOTO 20 ENDIF IF (DEG .GT. 0) THEN WF(I) = DEG 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 HEAD (DEG) = I ELSE NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0 W (I) = 0 ENDIF 20 CONTINUE NLEFT = TOTEL-NEL 30 IF (NEL .LT. TOTEL) THEN 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 J = NEXT(ME) K = WF(ME) IF(CONSTRAINT(ME) .LT. 0) THEN K = -1 ENDIF 55 CONTINUE IF (J.GT.0) THEN 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 HEAD (DEG) = INEXT ENDIF ELSE IF(CONSTRAINT(ME) .GE. 0) GOTO 59 56 CONTINUE IF(NEXT(ME) .NE. 0) THEN ME = NEXT(ME) IF(CONSTRAINT(ME) .GE. 0) THEN GOTO 59 ELSE GOTO 56 ENDIF ELSE 57 DEG = DEG+1 ME = HEAD(DEG) IF(ME .GT. 0) THEN IF(CONSTRAINT(ME) .GE. 0) THEN GOTO 59 ELSE GOTO 56 ENDIF ELSE GOTO 57 ENDIF ENDIF 59 PREV = LAST (ME) INEXT = NEXT (ME) IF(PREV .NE. 0) THEN NEXT(PREV) = INEXT ELSE HEAD (DEG) = INEXT ENDIF IF (INEXT .NE. 0) LAST (INEXT) = PREV ENDIF 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 ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN 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 DEGME = DEGME + NVI NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I IF (DEGREE(I).NE.N2) THEN 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 HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 60 CONTINUE NEWMEM = 0 ELSE P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME DO 120 KNT1 = 1, ELENME + 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 DO 110 KNT2 = 1, LN 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 IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2 IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = IW (PN) 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) = PE (J) PE (J) = PDST PDST = PDST + 1 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 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).NE.N2) THEN 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 HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN PE (E) = -ME 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) = PME2 - PME1 + 1 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) ELN = ELEN (I) IF (ELN .GT. 0) THEN 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 WE = WE - NVI ELSE IF (WE .NE. 0) THEN WE = DEGREE (E) + WNVI WF(E) = 0 ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE 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) DO 160 P = P1, P2 E = IW (P) DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN IF ( WF(E) .EQ. 0 ) THEN 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 PE (E) = -ME W (E) = 0 #endif ENDIF 160 CONTINUE ELEN (I) = PN - P1 + 1 P3 = PN DO 170 P = P2 + 1, P1 + LEN (I) - 1 J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN DEG = DEG + NVJ WF3 = WF3 + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE IF (DEGREE(I).EQ.N2) DEG = N2 #if defined (NOAGG4) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif PE (I) = -ME NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE IF (DEGREE(I).NE.N2) THEN IF ( DEGREE (I).LT.DEG ) THEN WF4 = 0 WF3 = 0 ELSE DEGREE(I) = DEG ENDIF ENDIF WF(I) = WF4 + 2*NVI*WF3 IW (PN) = IW (P3) IW (P3) = IW (P1) IW (P1) = ME LEN (I) = PN - P1 + 1 IF (DEG.NE.N2) THEN 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 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).NE.N2) ) 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 LN = LEN (I) ELN = ELEN (I) DO 210 P = PE (I) + 1, PE (I) + LN - 1 W (IW (P)) = WFLG 210 CONTINUE JLAST = I J = NEXT (I) 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 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 IF (LEN (J) .NE. LN) GO TO 240 IF (ELEN (J) .NE. ELN) GO TO 240 DO 230 P = PE (J) + 1, PE (J) + LN - 1 IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE 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) = -I WF(I) = max(WF(I),WF(J)) NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 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 P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN NV (I) = NVI IF (DEGREE(I).NE.N2) THEN DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN 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) 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 MINDEG = min (MINDEG, DEG) ENDIF IW (P) = I P = P + 1 ENDIF 260 CONTINUE NV (ME) = NVPIV + DEGME LEN (ME) = P - PME1 IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF GO TO 30 ENDIF IF (NEL.LT.N) THEN 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 PE(X) = -ME ELSEIF (DEGREE(X).EQ.N2) THEN NEL = NEL + NV(X) PE(X) = -ME ELEN(X) = 0 NV(X) = 0 ENDIF ENDDO ELEN(ME) = NELME NV(ME) = N-NREAL PE(ME) = 0 IF (NEL.NE.N) THEN NCMPA = -N - 1 GOTO 500 ENDIF ENDIF DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = -PE (I) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = -PE (J) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = -PE (J) PE (J) = -E 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 IF(.TRUE.) 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 500 PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_560 SUBROUTINE MUMPS_422 & ( THRESH, NDENSE, & N, IWLEN, PE, PFREE, LEN, IW, NV, & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, & PERM, LISTVAR_SCHUR, SIZE_SCHUR, AGG6 ) IMPLICIT NONE INTEGER N, IWLEN, PE(N), PFREE, LEN(N), IW(IWLEN), NV(N), & ELEN(N), LAST(N), NCMPA, DEGREE(N), HEAD(N), NEXT(N), & W(N), SIZE_SCHUR LOGICAL AGG6 INTEGER NDENSE(N), LISTVAR_SCHUR(max(1,SIZE_SCHUR)) INTEGER PERM(N) INTEGER THRESH INTEGER THRESM, NDME, PERMeqN INTEGER NBD,NBED, NBDM, LASTD, NELME LOGICAL IDENSE INTEGER FDEG, ThresMin, ThresPrev, IBEGSchur, NbSchur, & ThresMinINIT LOGICAL SchurON INTEGER DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER MAXINT_N INTEGER(8) HASH, HMOD INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC INTRINSIC max, min, mod IF (N.EQ.1) THEN ELEN(1) = 1 LAST(1) = 1 PE(1) = 0 NV(1) = 1 NCMPA = 0 RETURN ENDIF SIZE_SCHUR = min(N,SIZE_SCHUR) SIZE_SCHUR = max(0,SIZE_SCHUR) SchurON = (SIZE_SCHUR > 0) IBEGSchur = N-SIZE_SCHUR+1 IF (THRESH.GT.N) THRESH = N IF (THRESH.LT.0) THRESH = 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 ENDIF ENDIF ENDDO ENDIF IF (SchurON) THEN THRESM = N ThresMin = N ThresPrev = N ELSE THRESM = max(int(31*N/32),THRESH) 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 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 DO 20 I = 1, N 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 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 + LEN(ME) -1 LN = P1 ELN = P1 DO 55 P=P1,P2 E= IW(P) IF (W(E).EQ.WFLG) GOTO 55 W(E) = WFLG IF (PE(E).LT.0) THEN X = E 53 X = -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(LN) = IW(ELN) IW(ELN) = E LN = LN+1 ELN = ELN + 1 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(LN)=E LN = LN+1 ENDIF 55 CONTINUE WFLG = WFLG + 1 LEN(ME) = LN-P1 ELEN(ME) = ELN- 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_422 quasi dense rows remains' CALL MUMPS_ABORT() ENDIF NbSchur = 0 NELME = -(NEL+1) DO 59 X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN PE(X) = -LISTVAR_SCHUR(1) ELSE IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN PE(X) = -LISTVAR_SCHUR(1) ELSEIF (DEGREE(X).EQ.N+1) THEN NEL = NEL + NV(X) PE(X) = -ME ELEN(X) = 0 NV(X) = 0 NbSchur = NbSchur+ 1 ENDIF 59 CONTINUE IF (NbSchur.NE.SIZE_SCHUR) then write(6,*) ' Internal error 2 in QAMD :', & ' Schur size expected:',SIZE_SCHUR, 'Real:', NbSchur CALL MUMPS_ABORT() ENDIF ELEN(ME) = NELME NV(ME) = NBD PE(ME) = 0 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 DO I=1, SIZE_SCHUR PE(LISTVAR_SCHUR(I)) = -LISTVAR_SCHUR(1) ENDDO PE(LISTVAR_SCHUR(1)) = 0 NV( LISTVAR_SCHUR(1))= NV(ME) NV(ME) = 0 ELEN( LISTVAR_SCHUR(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 + LEN (ME) - 1 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 DO 120 KNT1 = 1, ELENME + 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 DO 110 KNT2 = 1, LN 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 IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2 IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = IW (PN) 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) = PE (J) PE (J) = PDST PDST = PDST + 1 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 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) = -ME 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) = PME2 - PME1 + 1 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) + ELN - 1 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) = -ME 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) = PN - P1 + 1 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) = -ME 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) = 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) + LN - 1 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) + LN - 1 IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE IF (PERM(J).GT.PERM(X)) THEN PE (J) = -X NV (X) = NV (X) + NV (J) NV (J) = 0 ELEN (J) = 0 ELSE PE (X) = -J 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 + ELEN(I) - 1 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) = P - PME1 IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF GO TO 30 ENDIF 265 CONTINUE DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = -PE (I) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = -PE (J) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = -PE (J) PE (J) = -E 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 PERM(PERMeqN) = N ENDIF PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_422 SUBROUTINE MUMPS_276( ICNTL, INFO, COMM, ID ) INTEGER ICNTL(40), INFO(40), COMM, ID INCLUDE 'mpif.h' INTEGER IN( 2 ), OUT( 2 ) 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_276 SUBROUTINE MUMPS_137( 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_170 INTEGER MUMPS_330 EXTERNAL MUMPS_170, MUMPS_330 INCLUDE 'mumps_headers.h' FLOP1 = 0.0D0 IF (MUMPS_170(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_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL MUMPS_511(NFRONT,NPIV,NPIV,KEEP50,LEVEL,FLOP1) RETURN END SUBROUTINE MUMPS_137 SUBROUTINE MUMPS_511(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) 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_511 SUBROUTINE MUMPS_81(MYID, INODE, N, IOLDPS, & HF, NFRONT, NFRONT_EFF, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & PROCNODE_STEPS, SLAVEF ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, IOLDPS, HF, NFRONT, & NASS1, LIW, NASS, & NUMSTK, NUMORG, IWPOSCB INTEGER, intent(in) :: KEEP(500) INTEGER(8) , intent(in) ::KEEP8(150) INTEGER STEP(N), & PIMASTER(KEEP(28)), & PTRAIW(N), IW(LIW), & ITLOC(N+KEEP(253)), FILS(N), FRERE(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) INTEGER, intent(inout) :: NBPROCFILS(KEEP(28)) LOGICAL, intent(in) :: NIV1 INTEGER, intent(inout) :: IFLAG LOGICAL, intent(out) :: SON_LEVEL2 INTEGER, intent(out) :: NFRONT_EFF INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF INTEGER, intent(in) :: DAD (KEEP(28)), IFSON, MYID INTEGER NEWEL, INEW, IOLDP2, INEW1, & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, & ITRANS, J, JJ, J1, J2, J3, JT1, ISON, IELL, LSTK, & NROWS, HS, IP1, IP2, K1, K2, IBROT, IORG, & I, K LOGICAL LEVEL1 INTEGER MUMPS_810, MUMPS_330 EXTERNAL MUMPS_810, MUMPS_330 INTEGER TYPESPLIT INCLUDE 'mumps_headers.h' SON_LEVEL2 = .FALSE. IOLDP2 = IOLDPS + HF - 1 ICT11 = IOLDP2 + NFRONT NTOTFS = 0 TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), & SLAVEF) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN J2 = PIMASTER(STEP(IFSON)) LSTK = IW(J2 +KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1 = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN write(6,*) MYID, ':', & ' Internal error 2 in MUMPS_BUILD__INDEX ', & ' interior split node of type 1 ' CALL MUMPS_ABORT() ELSE I= MUMPS_330(PROCNODE_STEPS(STEP(IFSON)),SLAVEF) J= MUMPS_810(PROCNODE_STEPS(STEP(IFSON)), & SLAVEF) IF (LEVEL1.or.J.LT.4) THEN write(6,*) MYID, ':', & ' Internal error 3 in MUMPS_81 ', & ' son', IFSON, & ' of interior split node', INODE, ' of type 1 ', & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J CALL MUMPS_ABORT() ELSE NBPROCFILS(STEP(IFSON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(IFSON)) ENDIF ENDIF IF ( J2.GT. IWPOSCB ) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 J3 = J1 + NELIM - 1 IF (NELIM.GT.0) THEN DO JJ=J1,J3 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) IW(ICT11 + NTOTFS) = JT1 IW(JJ) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) ENDDO ENDIF DO JJ =J3+1, J3+NUMORG NTOTFS = NTOTFS + 1 JT1 = IW(JJ) ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO DO JJ =J3+NUMORG+1, J2 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO NFRONT_EFF = NTOTFS IBROT = INODE DO IORG = 1, NUMORG K1 = PTRAIW(IBROT) + 2 JT1 = INTARR(K1) INTARR(K1) = ITLOC(JT1) IBROT = FILS(IBROT) K2 = K1 + INTARR(K1 - 2) - INTARR(K1 - 1) K1 = K1 + 1 IF (K1 .LE. K2) THEN DO JJ = K1, K2 J = INTARR(JJ) INTARR(JJ) = ITLOC(J) ENDDO ENDIF ENDDO K1 = IOLDPS+HF DO JJ=K1+NELIM,K1+NFRONT_EFF-1 ITLOC(IW(JJ)) = 0 ENDDO RETURN ENDIF NEWEL = IOLDP2 + NASS1 NFRONT_EFF = NASS1 IN = INODE INEW = IOLDPS + HF INEW1 = 1 50 J1 = PTRAIW(IN) + 2 JT1 = INTARR(J1) INTARR(J1) = INEW1 ITLOC(JT1) = INEW1 IW(INEW) = JT1 INEW = INEW + 1 INEW1 = INEW1 + 1 IN = FILS(IN) IF (IN .GT. 0) GOTO 50 IF (TYPESPLIT.EQ.4) THEN IBROT = INODE DO WHILE & ( & ( MUMPS_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .EQ.6 & ) & ) IBROT = DAD(STEP(IBROT)) IN = IBROT DO WHILE (IN.GT.0) NFRONT_EFF = NFRONT_EFF+1 NEWEL = NEWEL + 1 ITLOC(IN) = NFRONT_EFF IW(NEWEL) = IN IN = FILS( IN ) ENDDO ENDDO ENDIF IF (NUMSTK .NE. 0) THEN NTOTFS = NUMORG ISON = IFSON DO 100 IELL = 1, NUMSTK J2 = PIMASTER(STEP(ISON)) LSTK = IW(J2+KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1 = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN NBPROCFILS(STEP(ISON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON ELSE IF (LEVEL1) THEN NBPROCFILS(STEP(ISON)) = 1 ELSE NBPROCFILS(STEP(ISON)) = NSLSON ENDIF NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(ISON)) ENDIF IF (J2.GT.IWPOSCB) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 - KEEP(253) J3 = J1 + NELIM - 1 IF (NELIM .EQ. 0) GOTO 70 DO 60 JJ = J1, J3 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 60 CONTINUE 70 J1 = J3 + 1 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN DO 80 JJ = J1, J2 J = IW(JJ) IF (ITLOC(J) .EQ. 0) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW(NEWEL) = J IW(JJ) = NFRONT_EFF ITLOC(J) = NFRONT_EFF ELSE IW(JJ) = ITLOC(J) ENDIF 80 CONTINUE ELSE DO 90 JJ = J1, J2 IW(JJ) = ITLOC(IW(JJ)) 90 CONTINUE ENDIF DO JJ=J2+1, J2+KEEP(253) IW(JJ)=NFRONT-KEEP(253)+JJ-J2 ENDDO ISON = FRERE(STEP(ISON)) 100 CONTINUE ENDIF IBROT = INODE DO 120 IORG = 1, NUMORG J1 = PTRAIW(IBROT) + 2 IBROT = FILS(IBROT) J2 = J1 + INTARR(J1 - 2) - INTARR(J1 - 1) J1 = J1 + 1 IF (J1 .LE. J2) THEN DO 110 JJ = J1, J2 J = INTARR(JJ) IF (ITLOC(J) .EQ. 0) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW(NEWEL) = J INTARR(JJ) = NFRONT_EFF ITLOC(J) = NFRONT_EFF ELSE INTARR(JJ) = ITLOC(J) ENDIF 110 CONTINUE ENDIF 120 CONTINUE IF ( (TYPESPLIT.EQ.4).AND.(NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN IBROT = INODE DO WHILE & ( & ( MUMPS_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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)) J1 = PTRAIW(IN) + 2 J2 = J1 + INTARR(J1 - 2) - INTARR(J1-1) IN = FILS( IN ) DO JJ = J1+1, J2 J = INTARR( JJ ) 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 ENDIF IF ( KEEP(253).NE.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 ENDDO NFRONT_EFF = NFRONT_EFF + KEEP(253) ENDIF IF (NFRONT.NE.NFRONT_EFF) THEN IF (NUMORG.EQ.NASS1) THEN IP1 = IOLDPS + HF IP2 = IOLDPS + HF + NFRONT_EFF - 1 DO I = IP1, IP2 IW(I + NFRONT_EFF) = IW(I) ENDDO ELSE IP1 = IOLDPS + NFRONT + HF + NUMORG IP2 = IOLDPS + HF + NFRONT_EFF + NUMORG DO I=1,NASS IW(IP2+I-1)=IW(IP1+I-1) ENDDO IP1 = IOLDPS + NASS1 + HF IP2 = IOLDPS + HF + NFRONT - 1 DO I = IP1, IP2 IW(I + NFRONT_EFF) = IW(I) ENDDO IP1 = IOLDPS + HF IP2 = IOLDPS + HF + NUMORG - 1 DO I = IP1, IP2 IW(I + NFRONT_EFF) = IW(I) ENDDO ENDIF ELSE IP1 = IOLDPS + NASS1 + HF IP2 = IOLDPS + HF + NFRONT - KEEP(253) - 1 DO I = IP1, IP2 IW(I + NFRONT) = IW(I) ENDDO IP1 = IOLDPS + HF IP2 = IOLDPS + HF + NUMORG - 1 DO I = IP1, IP2 IW(I + NFRONT) = IW(I) ENDDO ENDIF K1 = IOLDPS + HF + NUMORG K2 = K1 + NFRONT_EFF - 1 + NASS DO 150 K = K1, K2 I = IW(K) ITLOC(I) = 0 150 CONTINUE RETURN END SUBROUTINE MUMPS_81 SUBROUTINE MUMPS_124( & NUMELT, LIST_ELT, & MYID, INODE, N, IOLDPS, & HF, NFRONT, NFRONT_EFF, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, & IW, LIW, & INTARR, LINTARR, ITLOC, RHS_MUMPS, & FILS, FRERE_STEPS, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD, PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IMPLICIT NONE INTEGER NELT, INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, & NUMSTK, NUMORG, IWPOSCB, IFSON, MYID, IFLAG, & LINTARR, NUMELT, NFRONT_EFF INTEGER KEEP(500) INTEGER LIST_ELT(*) INTEGER STEP(N), & PIMASTER(KEEP(28)), & PTRAIW(NELT+1), IW(LIW), & ITLOC(N+KEEP(253)), FILS(N), & FRERE_STEPS(KEEP(28)), & NBPROCFILS(KEEP(28)) COMPLEX, POINTER, DIMENSION(:) :: RHS_MUMPS INTEGER INTARR(LINTARR) LOGICAL SON_LEVEL2, NIV1 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 NEWEL, INEW, IOLDP2, INEW1, & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, & ITRANS, J, JJ, J1, J2, J3, JT1, ISON, IELL, LSTK, & NROWS, HS, IP1, IP2, K1, K2, & I, K, ELTI LOGICAL LEVEL1 INTEGER MUMPS_810, MUMPS_330 EXTERNAL MUMPS_810, MUMPS_330 INTEGER TYPESPLIT, NUMELT_IBROT, IBROT INCLUDE 'mumps_headers.h' SON_LEVEL2 = .FALSE. IOLDP2 = IOLDPS + HF - 1 NTOTFS = 0 ICT11 = IOLDP2 + NFRONT TYPESPLIT = MUMPS_810 (PROCNODE_STEPS(STEP(INODE)), & SLAVEF) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN J2 = PIMASTER(STEP(IFSON)) LSTK = IW(J2 +KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1 = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN write(6,*) MYID, ':', & ' Internal error 2 in MUMPS_BUILD__INDEX ', & ' interior split node of type 1 ' CALL MUMPS_ABORT() ELSE I= MUMPS_330(PROCNODE_STEPS(STEP(IFSON)),SLAVEF) J= MUMPS_810(PROCNODE_STEPS(STEP(IFSON)), & SLAVEF) IF (LEVEL1.or.J.LT.4) THEN write(6,*) MYID, ':', & ' Internal error 3 in MUMPS_81 ', & ' son', IFSON, & ' of interior split node', INODE, ' of type 1 ', & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J CALL MUMPS_ABORT() ELSE NBPROCFILS(STEP(IFSON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(IFSON)) ENDIF ENDIF IF ( J2.GT. IWPOSCB ) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 J3 = J1 + NELIM - 1 IF (NELIM.GT.0) THEN DO JJ=J1,J3 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) IW(ICT11 + NTOTFS) = JT1 IW(JJ) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) ENDDO ENDIF DO JJ =J3+1, J2 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO NFRONT_EFF = NTOTFS DO IELL=1,NUMELT ELTI = LIST_ELT(IELL) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 DO JJ=J1,J2 J = INTARR(JJ) INTARR(JJ) = ITLOC(J) END DO ENDDO K1 = IOLDPS+HF DO JJ=K1+NELIM,K1+NFRONT_EFF-1 ITLOC(IW(JJ)) = 0 ENDDO RETURN ENDIF NEWEL = IOLDP2 + NASS1 NFRONT_EFF = NASS1 IN = INODE INEW = IOLDPS + HF INEW1 = 1 DO WHILE (IN.GT.0) ITLOC(IN) = INEW1 IW(INEW) = IN INEW1 = INEW1 + 1 INEW = INEW + 1 IN = FILS(IN) END DO IF (TYPESPLIT.EQ.4) THEN IBROT = INODE DO WHILE & ( & ( MUMPS_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .EQ.6 & ) & ) IBROT = DAD(STEP(IBROT)) IN = IBROT DO WHILE (IN.GT.0) NFRONT_EFF = NFRONT_EFF+1 NEWEL = NEWEL + 1 ITLOC(IN) = NFRONT_EFF IW(NEWEL) = IN IN = FILS( IN ) ENDDO ENDDO ENDIF IF (NUMSTK .NE. 0) THEN NTOTFS = NUMORG ISON = IFSON DO 100 IELL = 1, NUMSTK J2 = PIMASTER(STEP(ISON)) LSTK = IW(J2+KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1 = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN NBPROCFILS(STEP(ISON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON ELSE IF (LEVEL1) THEN NBPROCFILS(STEP(ISON)) = 1 ELSE NBPROCFILS(STEP(ISON)) = NSLSON ENDIF NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(ISON)) ENDIF IF (J2.GT.IWPOSCB) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 +KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 - KEEP(253) J3 = J1 + NELIM - 1 IF (NELIM .EQ. 0) GOTO 70 DO 60 JJ = J1, J3 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) 60 CONTINUE 70 J1 = J3 + 1 IF (NASS1 .NE. NFRONT) THEN DO 80 JJ = J1, J2 J = IW(JJ) IF (ITLOC(J) .EQ. 0) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW(NEWEL) = J IW(JJ) = NFRONT_EFF ITLOC(J) = NFRONT_EFF ELSE IW(JJ) = ITLOC(J) ENDIF 80 CONTINUE ELSE DO 90 JJ = J1, J2 IW(JJ) = ITLOC(IW(JJ)) 90 CONTINUE ENDIF DO JJ=J2+1, J2+KEEP(253) IW(JJ)=NFRONT-KEEP(253)+JJ-J2 ENDDO ISON = FRERE_STEPS(STEP(ISON)) 100 CONTINUE ENDIF DO IELL=1,NUMELT ELTI = LIST_ELT(IELL) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 DO JJ=J1,J2 J = INTARR(JJ) IF (ITLOC(J) .EQ. 0) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW(NEWEL) = J INTARR(JJ) = NFRONT_EFF ITLOC(J) = NFRONT_EFF ELSE INTARR(JJ) = ITLOC(J) ENDIF END DO ENDDO IF ( (TYPESPLIT.EQ.4).AND.(NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN IBROT = INODE DO WHILE & ( & ( MUMPS_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 DO JJ=J1,J2 J = INTARR( JJ ) 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) EXIT ENDDO ENDIF 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 ENDDO NFRONT_EFF = NFRONT_EFF + KEEP(253) ENDIF IF (NFRONT.NE.NFRONT_EFF) THEN IF (NUMORG.EQ.NASS1) THEN IP1 = IOLDPS + HF IP2 = IOLDPS + HF + NFRONT_EFF - 1 DO I = IP1, IP2 IW(I + NFRONT_EFF) = IW(I) ENDDO ELSE IP1 = IOLDPS + NFRONT + HF + NUMORG IP2 = IOLDPS + HF + NFRONT_EFF + NUMORG DO I=1,NASS IW(IP2+I-1)=IW(IP1+I-1) ENDDO IP1 = IOLDPS + NASS1 + HF IP2 = IOLDPS + HF + NFRONT - 1 DO I = IP1, IP2 IW(I + NFRONT_EFF) = IW(I) ENDDO IP1 = IOLDPS + HF IP2 = IOLDPS + HF + NUMORG - 1 DO I = IP1, IP2 IW(I + NFRONT_EFF) = IW(I) ENDDO ENDIF ELSE IP1 = IOLDPS + NASS1 + HF IP2 = IOLDPS + HF + NFRONT - 1 DO I = IP1, IP2 IW(I + NFRONT) = IW(I) ENDDO IP1 = IOLDPS + HF IP2 = IOLDPS + HF + NUMORG - 1 DO I = IP1, IP2 IW(I + NFRONT) = IW(I) ENDDO ENDIF Pos_First_NUMORG = ITLOC(INODE) K1 = IOLDPS + HF + NUMORG K2 = K1 + NFRONT_EFF - 1 + NASS DO 150 K = K1, K2 I = IW(K) ITLOC(I) = 0 150 CONTINUE RETURN END SUBROUTINE MUMPS_124 SUBROUTINE MUMPS_86(MYID, INODE, N, IOLDPS, & HF, NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, IW, LIW, & INTARR, ITLOC, RHS_MUMPS, FILS, FRERE_STEPS, & SON_LEVEL2, NIV1, NBPROCFILS, KEEP,KEEP8, IFLAG, & ISON_IN_PLACE, PROCNODE_STEPS, SLAVEF ) IMPLICIT NONE INTEGER INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, & NUMSTK, NUMORG, IWPOSCB, IFSON, MYID INTEGER, intent(in) :: ISON_IN_PLACE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N), PIMASTER(KEEP(28)), & PTRAIW(N), IW(LIW), & ITLOC(N+KEEP(253)), FILS(N), FRERE_STEPS(KEEP(28)), & NBPROCFILS(KEEP(28)), PERM(N) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) 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 NELIM_SON_IN_PLACE INTEGER NEWEL, IOLDP2, INEW, INEW1, & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, & ITRANS, J, JJ, J1, J2, J3, JT1, ISON, IELL, LSTK, & NROWS, HS, IP1, IP2, K1, K2, IBROT, IORG, & I, K, JDEBROW, ILOC, NEWEL_SAVE, NEWEL1_SAVE, & LAST_J_ASS, JMIN, MIN_PERM LOGICAL LEVEL1 INTEGER TYPESPLIT INCLUDE 'mumps_headers.h' INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTTRI, PTLAST INTEGER MUMPS_810, MUMPS_330 EXTERNAL MUMPS_810, MUMPS_330 TYPESPLIT = MUMPS_810 (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 J2 = PIMASTER(STEP(IFSON)) LSTK = IW(J2 +KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) IF ( ISON_IN_PLACE > 0 ) THEN IF (ISON_IN_PLACE.NE.IFSON) THEN write(6,*) MYID, ':', & ' Internal error 1 in MUMPS_86 ', & ' in place node is not the first son a interior split node ' CALL MUMPS_ABORT() ENDIF NELIM_SON_IN_PLACE = NELIM ENDIF NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1 = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN write(6,*) MYID, ':', & ' Internal error 2 in MUMPS_86 ', & ' interior split node of type 1 ' CALL MUMPS_ABORT() ELSE I= MUMPS_330(PROCNODE_STEPS(STEP(IFSON)),SLAVEF) J= MUMPS_810(PROCNODE_STEPS(STEP(IFSON)), & SLAVEF) IF (LEVEL1.or.J.LT.4) THEN write(6,*) MYID, ':', & ' Internal error 3 in MUMPS_86 ', & ' son', IFSON, & ' of interior split node', INODE, ' of type 1 ', & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J CALL MUMPS_ABORT() ELSE NBPROCFILS(STEP(IFSON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(IFSON)) ENDIF ENDIF IF ( J2.GT. IWPOSCB ) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 J3 = J1 + NELIM - 1 IF (NELIM.GT.0) THEN DO JJ=J1,J3 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) IW(ICT11 + NTOTFS) = JT1 IW(JJ) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) ENDDO ENDIF DO JJ =J3+1, J3+NUMORG NTOTFS = NTOTFS + 1 JT1 = IW(JJ) ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO DO JJ =J3+NUMORG+1, J2 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO NFRONT_EFF = NTOTFS IBROT = INODE DO IORG = 1, NUMORG K1 = PTRAIW(IBROT) + 2 JT1 = INTARR(K1) INTARR(K1) = ITLOC(JT1) IBROT = FILS(IBROT) K2 = K1 + INTARR(K1 - 2) - INTARR(K1 - 1) K1 = K1 + 1 IF (K1 .LE. K2) THEN DO JJ = K1, K2 J = INTARR(JJ) INTARR(JJ) = ITLOC(J) ENDDO ENDIF ENDDO K1 = IOLDPS+HF DO JJ=K1+NELIM,K1+NFRONT_EFF-1 ITLOC(IW(JJ)) = 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 J2 = PIMASTER(STEP(ISON)) LSTK = IW(J2 +KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF ( J2.GT. IWPOSCB ) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 J3 = J1 + NELIM - 1 DO JJ = J1, J3 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) ENDDO NELIM_SON_IN_PLACE = NTOTFS ENDIF IN = INODE INEW = IOLDPS + HF + NTOTFS INEW1 = NTOTFS + 1 JDEBROW = PTRAIW(INODE)+3 PTTRI(NUMSTK+1) = JDEBROW PTLAST(NUMSTK+1) = JDEBROW + INTARR(JDEBROW-3) - 1 50 J1 = PTRAIW(IN) + 2 JT1 = INTARR(J1) INTARR(J1) = 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 J2 = PIMASTER(STEP(ISON)) LSTK = IW(J2 +KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1 = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN NBPROCFILS(STEP(ISON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON ELSE IF (LEVEL1) THEN NBPROCFILS(STEP(ISON)) = 1 ELSE NBPROCFILS(STEP(ISON)) = NSLSON ENDIF NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(ISON)) ENDIF IF (J2.GT.IWPOSCB) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 - KEEP(253) J3 = J1 + NELIM - 1 IF (NELIM .NE. 0 .AND. ISON.NE.ISON_IN_PLACE) THEN DO JJ = J1, J3 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) ENDDO ENDIF PTTRI(IELL) = J2+1 PTLAST(IELL) = J2 J1 = J3 + 1 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN DO JJ = J1, J2 J = IW(JJ) IF (ITLOC(J) .EQ. 0) THEN PTTRI(IELL) = JJ EXIT ENDIF ENDDO ELSE DO JJ = J1, J2 IW(JJ) = ITLOC(IW(JJ)) ENDDO DO JJ=J2+1, J2+KEEP(253) IW(JJ)=NFRONT-KEEP(253)+JJ-J2 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( 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 ILOC = PTTRI( IELL ) IF ( ILOC .LE. PTLAST( IELL ) ) THEN IF ( PERM( IW( ILOC ) ) .LT. MIN_PERM ) THEN JMIN = 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( ILOC ) ) .LT. MIN_PERM ) THEN JMIN = INTARR( 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 IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( IW( PTTRI( IELL ) ) .eq. LAST_J_ASS ) & PTTRI( IELL ) = PTTRI( IELL ) + 1 ENDIF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( PERM(IW( PTTRI( IELL )) ) .LT. MIN_PERM ) THEN JMIN = 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( 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( PTTRI(IELL) )) .LT. MIN_PERM) THEN JMIN = INTARR( 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 J1 = PTRAIW(IBROT) + 2 J2 = J1 + INTARR(J1 - 2) - INTARR(J1-1) IBROT = FILS( IBROT ) IF ( IORG.EQ. 1) THEN IF ( KEEP(50).NE.0 ) CYCLE J1 = J1 + 1 + INTARR(J1-2) ELSE J1 = J1 + 1 ENDIF DO JJ = J1, J2 J = INTARR( JJ ) 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_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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)) J1 = PTRAIW(IN) + 2 J2 = J1 + INTARR(J1 - 2) - INTARR(J1-1) IN = FILS( IN ) DO JJ = J1, J2 J = INTARR( JJ ) 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 ENDIF ENDIF IF ( NEWEL1_SAVE .eq. NFRONT_EFF ) THEN DO JJ=NASS1+1, NFRONT_EFF IW( IOLDP2+JJ ) = IW( ICT11+JJ ) ENDDO ELSE CALL MUMPS_308( N, PERM, & IW( NEWEL_SAVE + 1 ), NFRONT_EFF - NEWEL1_SAVE ) CALL MUMPS_309( 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 JJ = NASS1+1, NFRONT_EFF IW(ICT11 + JJ) = IW(IOLDP2+JJ) 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.NE.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 ENDIF IF ((NUMSTK .NE. 0).AND.(NFRONT-KEEP(253).GT.NASS1)) THEN ISON = IFSON DO IELL = 1, NUMSTK J2 = PIMASTER(STEP(ISON)) LSTK = IW(J2+KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) NCOLS = NPIVS + LSTK NROWS = NCOLS IF (J2.GT.IWPOSCB) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ENDIF HS = NSLSON + 6 +KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 J3 = J1 + NELIM - 1 J1 = J3 + 1 DO JJ = J1, J2 J = IW(JJ) IW(JJ) = ITLOC(J) ENDDO ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF IBROT = INODE DO IORG = 1, NUMORG J1 = PTRAIW(IBROT) + 2 IBROT = FILS(IBROT) J2 = J1 + INTARR(J1 - 2) - INTARR(J1 - 1) J1 = J1 + 1 IF (J1 .LE. J2) THEN DO JJ = J1, J2 J = INTARR(JJ) INTARR(JJ) = ITLOC(J) ENDDO ENDIF 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_86 SUBROUTINE MUMPS_308( 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_308 SUBROUTINE MUMPS_309( 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_309 SUBROUTINE MUMPS_125( & NUMELT, LIST_ELT, & MYID, INODE, N, IOLDPS, & HF, NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, & IW, LIW, & INTARR, LINTARR, ITLOC, RHS_MUMPS, & FILS, FRERE_STEPS, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD, PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IMPLICIT NONE INTEGER NELT, INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, & NUMSTK, NUMORG, IWPOSCB, IFSON, MYID, IFLAG, & LINTARR, NUMELT INTEGER KEEP(500) INTEGER LIST_ELT(*) INTEGER STEP(N), PIMASTER(KEEP(28)), & PTRAIW(NELT+1), IW(LIW), & ITLOC(N+KEEP(253)), FILS(N), FRERE_STEPS(KEEP(28)), & NBPROCFILS(KEEP(28)), PERM(N) COMPLEX :: RHS_MUMPS(KEEP(255)) 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 NEWEL, IOLDP2, INEW, INEW1, & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, & ITRANS, J, JJ, J1, J2, J3, JT1, ISON, IELL, LSTK, & NROWS, HS, IP1, IP2, K1, K2, IBROT, & I, K, ILOC, NEWEL_SAVE, NEWEL1_SAVE, & LAST_J_ASS, JMIN, MIN_PERM INTEGER TYPESPLIT, NUMELT_IBROT INTEGER ELTI INCLUDE 'mumps_headers.h' LOGICAL LEVEL1 INTEGER allocok INTEGER , ALLOCATABLE, DIMENSION(:) :: PTTRI, PTLAST INTEGER MUMPS_810, MUMPS_330 EXTERNAL MUMPS_810, MUMPS_330 Pos_First_NUMORG = 1 TYPESPLIT = MUMPS_810 (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 J2 = PIMASTER(STEP(IFSON)) LSTK = IW(J2 +KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1 = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN write(6,*) MYID, ':', & ' Internal error 2 in MUMPS_86 ', & ' interior split node of type 1 ' CALL MUMPS_ABORT() ELSE I= MUMPS_330(PROCNODE_STEPS(STEP(IFSON)),SLAVEF) J= MUMPS_810(PROCNODE_STEPS(STEP(IFSON)), & SLAVEF) IF (LEVEL1.or.J.LT.4) THEN write(6,*) MYID, ':', & ' Internal error 3 in MUMPS_86 ', & ' son', IFSON, & ' of interior split node', INODE, ' of type 1 ', & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J CALL MUMPS_ABORT() ELSE NBPROCFILS(STEP(IFSON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(IFSON)) ENDIF ENDIF IF ( J2.GT. IWPOSCB ) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 J3 = J1 + NELIM - 1 IF (NELIM.GT.0) THEN DO JJ=J1,J3 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) IW(ICT11 + NTOTFS) = JT1 IW(JJ) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) ENDDO ENDIF DO JJ =J3+1, J2 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO NFRONT_EFF = NTOTFS DO IELL=1,NUMELT ELTI = LIST_ELT(IELL) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 DO JJ=J1,J2 J = INTARR(JJ) INTARR(JJ) = ITLOC(J) END DO ENDDO Pos_First_NUMORG = ITLOC(INODE) K1 = IOLDPS+HF DO JJ=K1+NELIM,K1+NFRONT_EFF-1 ITLOC(IW(JJ)) = 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 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 J2 = PIMASTER(STEP(ISON)) LSTK = IW(J2 +KEEP(IXSZ)) NELIM = IW(J2 + 1+KEEP(IXSZ)) NPIVS = IW(J2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(J2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1 = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN NBPROCFILS(STEP(ISON)) = NSLSON NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) + NSLSON ELSE IF (LEVEL1) THEN NBPROCFILS(STEP(ISON)) = 1 ELSE NBPROCFILS(STEP(ISON)) = NSLSON ENDIF NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE))+ & NBPROCFILS(STEP(ISON)) ENDIF IF (J2.GT.IWPOSCB) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 - KEEP(253) J3 = J1 + NELIM - 1 IF (NELIM .NE. 0) THEN DO JJ = J1, J3 NTOTFS = NTOTFS + 1 JT1 = IW(JJ) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS IW(JJ) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(JJ - ITRANS) ENDDO ENDIF PTTRI(IELL) = J2+1 PTLAST(IELL) = J2 J1 = J3 + 1 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN DO JJ = J1, J2 J = IW(JJ) IF (ITLOC(J) .EQ. 0) THEN PTTRI(IELL) = JJ EXIT ENDIF ENDDO ELSE DO JJ = J1, J2 IW(JJ) = ITLOC(IW(JJ)) ENDDO DO JJ=J2+1, J2+KEEP(253) IW(JJ)=NFRONT-KEEP(253)+JJ-J2 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 ILOC = PTTRI( IELL ) IF ( ILOC .LE. PTLAST( IELL ) ) THEN IF ( PERM( IW( ILOC ) ) .LT. MIN_PERM ) THEN JMIN = 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 IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( IW( PTTRI( IELL ) ) .eq. LAST_J_ASS ) & PTTRI( IELL ) = PTTRI( IELL ) + 1 ENDIF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( PERM(IW( PTTRI( IELL )) ) .LT. MIN_PERM ) THEN JMIN = 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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 DO JJ=J1,J2 J = INTARR( JJ ) 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_810 & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),SLAVEF) & .EQ.5 & ) & .OR. & ( MUMPS_810 & (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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 DO JJ=J1,J2 J = INTARR( JJ ) 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 ENDIF END IF IF ( NEWEL1_SAVE .eq. NFRONT_EFF ) THEN DO JJ=NASS1+1, NFRONT_EFF IW( IOLDP2+JJ ) = IW( ICT11+JJ ) ENDDO ELSE CALL MUMPS_308( N, PERM, & IW( NEWEL_SAVE + 1 ), NFRONT_EFF - NEWEL1_SAVE ) CALL MUMPS_309( 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 JJ = NASS1+1, NFRONT_EFF IW(ICT11 + JJ) = IW(IOLDP2+JJ) 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)=IW(IP1+I) ENDDO ELSE IF (NFRONT .LT. NFRONT_EFF) THEN WRITE(*,*) "Internal error in MUMPS_125", & NFRONT, NFRONT_EFF CALL MUMPS_ABORT() ENDIF IF ((NUMSTK .NE. 0).AND. & (NFRONT-KEEP(253).GT.NASS1)) THEN ISON = IFSON DO IELL = 1, NUMSTK J2 = PIMASTER(STEP(ISON)) LSTK = IW(J2+KEEP(IXSZ)) NELIM = IW(J2 + 1 +KEEP(IXSZ)) NPIVS = IW(J2 + 3 +KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(J2 + 5 +KEEP(IXSZ)) NCOLS = NPIVS + LSTK NROWS = NCOLS IF (J2.GT.IWPOSCB) THEN NROWS = IW(J2 + 2+KEEP(IXSZ)) ENDIF HS = NSLSON + 6 +KEEP(IXSZ) J1 = J2 + HS + NROWS + NPIVS J2 = J1 + LSTK - 1 J3 = J1 + NELIM - 1 J1 = J3 + 1 DO JJ = J1, J2 J = IW(JJ) IW(JJ) = ITLOC(J) ENDDO ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF DO IELL=1,NUMELT ELTI = LIST_ELT(IELL) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 DO JJ=J1,J2 J = INTARR(JJ) INTARR(JJ) = ITLOC(J) END DO 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_125 INTEGER FUNCTION MUMPS_50 & ( SLAVEF, K48, K821, K50, & NFRONT, NCB) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50, NFRONT, NCB INTEGER(8), INTENT (IN) :: K821 INTEGER NSLAVESMIN, NASS, KMAX REAL Wmaster, Wtotal, Wmax INTEGER ACC,X REAL MUMPS_45 INTEGER MUMPS_497 EXTERNAL MUMPS_45, MUMPS_497 KMAX = MUMPS_497( 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_45(KMAX,NFRONT,NASS) Wtotal = MUMPS_45(NCB,NFRONT,NASS) Wmaster = real(NASS*NASS)*real(NASS)/(3.0) 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_50' CALL MUMPS_ABORT() ENDIF CALL MUMPS_ABORT_ON_OVERFLOW(K821, & "K821 too large in MUMPS_50" ) 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_50 = & min ( NSLAVESMIN, NCB ) RETURN END FUNCTION MUMPS_50 INTEGER FUNCTION MUMPS_52 & ( SLAVEF, K48, K821, K50, & NFRONT, NCB) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50,NFRONT, NCB INTEGER(8), INTENT(IN) :: K821 INTEGER NSLAVESMAX, KMAX, KMIN INTEGER NSLAVESMIN INTEGER MUMPS_497,MUMPS_442, & MUMPS_50, & MUMPS_46 EXTERNAL MUMPS_497,MUMPS_442, & MUMPS_50, & MUMPS_46 IF (K48 .eq. 0 .OR. K48.eq.3.OR.K48.EQ.5) THEN KMAX = MUMPS_497( K821, NCB ) KMIN = MUMPS_442( K821, K50, KMAX, NCB) NSLAVESMAX = MUMPS_46( & SLAVEF, K48, K50, KMIN, NFRONT, NCB ) ELSE NSLAVESMAX = SLAVEF-1 ENDIF NSLAVESMIN = MUMPS_50( & SLAVEF, K48, K821, K50, NFRONT, NCB ) NSLAVESMAX = max ( NSLAVESMAX, NSLAVESMIN ) MUMPS_52 = & min ( NSLAVESMAX, NCB ) RETURN END FUNCTION MUMPS_52 SUBROUTINE MUMPS_503( 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_497, MUMPS_442, & MUMPS_50 INTEGER MUMPS_497, MUMPS_442, & MUMPS_50 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_503" CALL MUMPS_ABORT() END IF ENDIF KMAX = MUMPS_497( KEEP8(21), NCB ) IF (WHAT .EQ.1.OR.WHAT.EQ.2) THEN NSLAVES = MUMPS_50( SLAVEF, KEEP(48), & KEEP8(21), KEEP(50), & NFR, NCB ) 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_442( KEEP8(21), KEEP(50), KMAX, NCB ) SIZEDUMMY = 1 IF (WHAT.GT.3) THEN CALL MUMPS_440( & WHAT-3, NSLAVES, NFR, NCB, & KMIN, KMAX, SLAVEF, & NBROWMAX, MAXSURFCB8, TABDUMMY, SIZEDUMMY) ELSE CALL MUMPS_440( & 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_503" 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_503 INTEGER FUNCTION MUMPS_46( 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_45 EXTERNAL MUMPS_45 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_45(BLSIZE,NFRONT,NASS) Wtotal = MUMPS_45(NCB,NFRONT,NASS) NSLAVES = max(nint ( Wtotal / Wblsize ), 1) ENDIF MUMPS_46 = & min ( NSLAVES,(SLAVEF-1) ) RETURN END FUNCTION MUMPS_46 SUBROUTINE MUMPS_440( & 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_45 EXTERNAL MUMPS_45 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_45(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_45(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_440: ', & ' size lastbloc ', BLSIZE CALL MUMPS_ABORT() ENDIF if (NCOLim1+BLSIZE.NE.NFRONT) then write(*,*) ' Error in MUMPS_440: ', & ' 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_440 SUBROUTINE MUMPS_441( & 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_442, MUMPS_497 EXTERNAL MUMPS_442, MUMPS_497, & MUMPS_440 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_497(KEEP8(21), NCB) KMIN = MUMPS_442(KEEP8(21), KEEP(50), KMAX, NCB) GETPOSITIONS = 3 SIZECOLTAB = SLAVEF+2 CALL MUMPS_440( & GETPOSITIONS, NSLAVES, NFRONT, NCB, & KMIN, KMAX, SLAVEF, & NBROWDUMMY, MAXSURFDUMMY8, & TAB_POS_IN_PERE(1), SIZECOLTAB) ENDIF RETURN END SUBROUTINE MUMPS_441 SUBROUTINE MUMPS_49( & 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_49 REAL FUNCTION MUMPS_45(NROW,NCOL,NASS) IMPLICIT NONE INTEGER, INTENT (IN) :: NROW,NCOL,NASS MUMPS_45 = real(NASS*NROW)* & real(2*NCOL - NASS - NROW + 1) RETURN END FUNCTION MUMPS_45 INTEGER FUNCTION MUMPS_12 & (K821, K48, K50, SLAVEF, & NCB, NFRONT, NSLAVES_less, NMB_OF_CAND ) IMPLICIT NONE INTEGER, INTENT( IN ) :: NCB, NFRONT, NSLAVES_less, & K48, K50, SLAVEF, NMB_OF_CAND INTEGER(8), INTENT(IN) :: K821 INTEGER NSLAVES INTEGER KMAX, NPIV, & NSLAVES_ref, NSLAVES_max REAL WK_MASTER, WK_SLAVE INTEGER MUMPS_497, MUMPS_50, & MUMPS_52 REAL MUMPS_45 EXTERNAL MUMPS_497, MUMPS_50, & MUMPS_52 EXTERNAL MUMPS_45 IF (NMB_OF_CAND.LE.0) THEN ENDIF IF ( (K48.EQ.0).OR. (K48.EQ.3) ) THEN KMAX = MUMPS_497( K821, NCB ) NSLAVES_ref = MUMPS_50( & SLAVEF, K48, K821, K50, NFRONT, NCB ) NSLAVES = NSLAVES_ref IF ( NSLAVES_ref.LT.SLAVEF ) THEN NSLAVES_max = MUMPS_52( & SLAVEF, K48, K821, K50, NFRONT, NCB ) 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_45(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_12 = NSLAVES RETURN END FUNCTION MUMPS_12 SUBROUTINE MUMPS_47( & 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).EQ.0) THEN BLSIZE = NCB / NSLAVES ISLAVE = min( NSLAVES, & ( POSITION - NASS - 1 ) / BLSIZE + 1 ) IPOSSLAVE = POSITION - NASS - ( ISLAVE - 1 ) * BLSIZE ELSEIF (KEEP(48).EQ.3) 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 ELSEIF (KEEP(48).EQ.4) 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 ELSEIF (KEEP(48).EQ.5) 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 WRITE(*,*) 'Error in MUMPS_47: undef strat' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_47 INTEGER FUNCTION MUMPS_442( 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_442 = 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_442 = KMIN RETURN END FUNCTION MUMPS_442 INTEGER FUNCTION MUMPS_497( KEEP821, NCB ) IMPLICIT NONE INTEGER, intent( in ) :: NCB INTEGER(8), intent( in ) :: KEEP821 INTEGER KMAX IF ( NCB .LE.0 ) THEN MUMPS_497 = 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_497 = max ( KMAX, 1 ) RETURN END FUNCTION MUMPS_497 SUBROUTINE MUMPS_546( IS, DS ) INTEGER IS, DS #if defined(t3e) IS = 8 DS = 16 #else IS = 4 DS = 8 #endif END SUBROUTINE MUMPS_546 SUBROUTINE MUMPS_SET_VERSION( VERSION_STR ) IMPLICIT NONE CHARACTER(LEN=*) :: VERSION_STR CHARACTER(LEN=*) :: V; PARAMETER (V = "4.10.0" ) IF ( len(V) .GT. 14 ) THEN WRITE(*,*) "Version string too long ( >14 characters )" CALL MUMPS_ABORT() END IF VERSION_STR = V RETURN END SUBROUTINE MUMPS_SET_VERSION SUBROUTINE MUMPS_420 & ( 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 JOB INTEGER N, IWLEN, PE(N), PFREE, LEN(N), IW(IWLEN), NV(N), & ELEN(N), LAST(N), NCMPA, DEGREE(N), HEAD(N), NEXT(N), & W(N) LOGICAL AGG6 INTEGER, intent(in) :: SIZE_COMPLEM_LIST INTEGER NDENSE(N) INTEGER, intent (in) :: COMPLEM_LIST(max(1,SIZE_COMPLEM_LIST)) INTEGER PERM(N) INTEGER THRESH 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, MAXMEM, ME, MEM, MINDEG, NEL, NEWMEM, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER MAXINT_N INTEGER(8) HASH, HMOD INTEGER P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, PN, PSRC INTRINSIC max, min, mod IF (N.EQ.1) THEN ELEN(1) = 1 LAST(1) = 1 PE(1) = 0 NV(1) = 1 RETURN ENDIF IF ( SIZE_COMPLEM_LIST < 0 .OR. SIZE_COMPLEM_LIST > N ) THEN WRITE(*,*) "Internal MUMPS_420", SIZE_COMPLEM_LIST,N CALL MUMPS_ABORT() ENDIF IF (JOB.EQ.2) THEN SchurON = .FALSE. ENDIF 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_420 on Options ' ENDIF IBEGSchur = N-SIZE_COMPLEM_LIST+1 IF (THRESH.GT.N) THRESH = N IF (THRESH.LT.0) THRESH = 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 ENDIF ENDIF ENDDO ENDIF ENDIF IF (SchurON) THEN THRESM = N ThresMin = N ThresPrev = N ELSE THRESM = max(int(31*N/32),THRESH) 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 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 + LEN(ME) -1 LN = P1 ELN = P1 DO 55 P=P1,P2 E= IW(P) IF (W(E).EQ.WFLG) GOTO 55 W(E) = WFLG IF (PE(E).LT.0) THEN X = E 53 X = -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(LN) = IW(ELN) IW(ELN) = E LN = LN+1 ELN = ELN + 1 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(LN)=E LN = LN+1 ENDIF 55 CONTINUE WFLG = WFLG + 1 LEN(ME) = LN-P1 ELEN(ME) = ELN- 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_420 ', & ' 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 ENDDO GOTO 265 ENDIF NELME = -(NEL+1) DO 59 X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN PE(X) = -COMPLEM_LIST(1) ELSEIF (DEGREE(X).EQ.N+1) THEN NEL = NEL + NV(X) PE(X) = -ME ELEN(X) = 0 NV(X) = 0 ENDIF 59 CONTINUE ELEN(ME) = NELME NV(ME) = NBD PE(ME) = 0 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)) = -COMPLEM_LIST(1) ENDDO PE(COMPLEM_LIST(1)) = 0 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 + LEN (ME) - 1 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 DO 120 KNT1 = 1, ELENME + 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 DO 110 KNT2 = 1, LN 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 IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2 IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = IW (PN) 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) = PE (J) PE (J) = PDST PDST = PDST + 1 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 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) = -ME 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) = PME2 - PME1 + 1 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) + ELN - 1 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) = -ME 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) = PN - P1 + 1 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) = -ME 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) = 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) + LN - 1 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) + LN - 1 IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE IF (PERM(J).GT.PERM(X)) THEN PE (J) = -X NV (X) = NV (X) + NV (J) NV (J) = 0 ELEN (J) = 0 ELSE PE (X) = -J 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 + ELEN(I) - 1 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) = P - PME1 IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF GO TO 30 ENDIF 265 CONTINUE DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = -PE (I) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = -PE (J) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = -PE (J) PE (J) = -E 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_420 SUBROUTINE MUMPS_209( 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_209 INTEGER FUNCTION MUMPS_330(PROCINFO_INODE, SLAVEF) IMPLICIT NONE INTEGER SLAVEF INTEGER PROCINFO_INODE, TPN IF (PROCINFO_INODE <= SLAVEF ) THEN MUMPS_330 = 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_330 = TPN END IF RETURN END FUNCTION MUMPS_330 INTEGER FUNCTION MUMPS_275(PROCINFO_INODE, SLAVEF) IMPLICIT NONE INTEGER SLAVEF INTEGER PROCINFO_INODE IF (SLAVEF == 1) THEN MUMPS_275 = 0 ELSE MUMPS_275=mod(2*SLAVEF+PROCINFO_INODE-1,SLAVEF) END IF RETURN END FUNCTION MUMPS_275 INTEGER FUNCTION MUMPS_810 (PROCINFO_INODE, SLAVEF) IMPLICIT NONE INTEGER, intent(in) :: SLAVEF INTEGER PROCINFO_INODE, TPN IF (PROCINFO_INODE <= SLAVEF ) THEN MUMPS_810 = 1 ELSE TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 IF ( TPN .LT. 1 ) TPN = 1 MUMPS_810 = TPN ENDIF RETURN END FUNCTION MUMPS_810 LOGICAL FUNCTION MUMPS_283( PROCINFO_INODE, SLAVEF ) IMPLICIT NONE INTEGER SLAVEF INTEGER TPN, PROCINFO_INODE TPN = (PROCINFO_INODE-1+2*SLAVEF)/SLAVEF - 1 MUMPS_283 = ( TPN .eq. 0 ) RETURN END FUNCTION MUMPS_283 LOGICAL FUNCTION MUMPS_167( PROCINFO_INODE, SLAVEF ) IMPLICIT NONE INTEGER SLAVEF INTEGER TPN, PROCINFO_INODE TPN = (PROCINFO_INODE-1+SLAVEF+SLAVEF)/SLAVEF - 1 MUMPS_167 = ( TPN .eq. -1 ) RETURN END FUNCTION MUMPS_167 LOGICAL FUNCTION MUMPS_170 & ( PROCINFO_INODE, SLAVEF ) IMPLICIT NONE INTEGER SLAVEF INTEGER TPN, PROCINFO_INODE TPN = (PROCINFO_INODE-1+SLAVEF+SLAVEF)/SLAVEF - 1 MUMPS_170 = & ( TPN .eq. -1 .OR. TPN .eq. 0 ) RETURN END FUNCTION MUMPS_170 LOGICAL FUNCTION MUMPS_358( 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_358 = .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_358 = .TRUE. END DO RETURN END FUNCTION MUMPS_358 SUBROUTINE MUMPS_291(T) DOUBLE PRECISION T DOUBLE PRECISION MPI_WTIME EXTERNAL MPI_WTIME T=MPI_WTIME() RETURN END SUBROUTINE MUMPS_291 SUBROUTINE MUMPS_292(T) DOUBLE PRECISION T DOUBLE PRECISION MPI_WTIME EXTERNAL MPI_WTIME T=MPI_WTIME()-T RETURN END SUBROUTINE MUMPS_292 SUBROUTINE MUMPS_558( 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_558 #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_243(MYID, COMM, INFO, INFOG, IRANK) IMPLICIT NONE INTEGER MYID, COMM, IRANK, INFO, INFOG(2) INCLUDE 'mpif.h' INTEGER IERR_MPI, MASTER INTEGER TEMP1(2), TEMP2(2) 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_243' CALL MUMPS_ABORT() END IF IRANK = TEMP2(2) ELSE IRANK = -1 END IF RETURN END SUBROUTINE MUMPS_243 SUBROUTINE MUMPS_362(N, LEAF, NBROOT, NROOT_LOC, & MYID_NODES, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) IMPLICIT NONE INTEGER N, LEAF, NROOT_LOC, NBROOT, 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_275 EXTERNAL MUMPS_275 NBLEAF = NA(1) NBROOT = NA(2) LEAF = 1 DO I = 1, NBLEAF INODE = NA(I+2) IF (MUMPS_275(PROCNODE_STEPS(STEP(INODE)),SLAVEF) & .EQ.MYID_NODES) THEN IPOOL(LEAF) = INODE LEAF = LEAF + 1 ENDIF ENDDO NROOT_LOC = 0 DO I = 1, NBROOT INODE = NA(I+2+NBLEAF) IF (MUMPS_275(PROCNODE_STEPS(STEP(INODE)), & SLAVEF).EQ.MYID_NODES) THEN NROOT_LOC = NROOT_LOC + 1 END IF ENDDO RETURN END SUBROUTINE MUMPS_362 LOGICAL FUNCTION MUMPS_438(TAB1,TAB2,LEN1,LEN2) IMPLICIT NONE INTEGER LEN1 , LEN2 ,I INTEGER TAB1(LEN1) INTEGER TAB2(LEN2) MUMPS_438=.FALSE. IF(LEN1 .NE. LEN2) THEN RETURN ENDIF DO I=1 , LEN1 IF(TAB1(I) .NE. TAB2(I)) THEN RETURN ENDIF ENDDO MUMPS_438=.TRUE. RETURN END FUNCTION MUMPS_438 SUBROUTINE MUMPS_463( 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_463 SUBROUTINE MUMPS_466( 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_466 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_633(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_633 SUBROUTINE MUMPS_749( 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_749 SUBROUTINE MUMPS_646( 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_646 SUBROUTINE MUMPS_736( 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_736 SUBROUTINE MUMPS_754(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, MEMCNT LOGICAL :: ICOPY, IFORCE INTEGER, POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER :: FMTA*60, FMTD*60 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 = (/ERRCODE, MINSIZE/) ELSE ERRTPL = (/-13, 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+MINSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 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-size(ARRAY) 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 END IF END IF RETURN END SUBROUTINE MUMPS_754 SUBROUTINE MUMPS_750(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, MEMCNT LOGICAL :: ICOPY, IFORCE REAL(kind(1.E0)), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER :: FMTA*60, FMTD*60 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 = (/ERRCODE, MINSIZE/) ELSE ERRTPL = (/-13, 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+MINSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 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-size(ARRAY) 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 END IF END IF RETURN END SUBROUTINE MUMPS_750 SUBROUTINE MUMPS_752(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, MEMCNT LOGICAL :: ICOPY, IFORCE REAL(kind(1.D0)), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER :: FMTA*60, FMTD*60 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 = (/ERRCODE, MINSIZE/) ELSE ERRTPL = (/-13, 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+MINSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 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-size(ARRAY) 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 END IF END IF RETURN END SUBROUTINE MUMPS_752 SUBROUTINE MUMPS_751(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, MEMCNT LOGICAL :: ICOPY, IFORCE COMPLEX(kind((1.E0,1.E0))), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER :: FMTA*60, FMTD*60 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 = (/ERRCODE, MINSIZE/) ELSE ERRTPL = (/-13, 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+MINSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 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-size(ARRAY) 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 END IF END IF RETURN END SUBROUTINE MUMPS_751 SUBROUTINE MUMPS_753(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, MEMCNT LOGICAL :: ICOPY, IFORCE COMPLEX(kind((1.D0,1.D0))), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER :: FMTA*60, FMTD*60 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 = (/ERRCODE, MINSIZE/) ELSE ERRTPL = (/-13, 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+MINSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT-size(ARRAY) 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-size(ARRAY) 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 END IF END IF RETURN END SUBROUTINE MUMPS_753 SUBROUTINE MUMPS_735(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_735 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_731( SIZE8, IERROR ) INTEGER(8), INTENT(IN) :: SIZE8 INTEGER, INTENT(OUT) :: IERROR CALL MUMPS_735(SIZE8, IERROR) RETURN END SUBROUTINE MUMPS_731 SUBROUTINE MUMPS_730(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_730 SUBROUTINE MUMPS_729(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_729 SUBROUTINE MUMPS_723( INT_ARRAY, I8 ) IMPLICIT NONE INTEGER(8), intent(in) :: I8 INTEGER, intent(inout) :: INT_ARRAY(2) INTEGER(8) :: I8TMP CALL MUMPS_729(I8TMP, INT_ARRAY) I8TMP = I8TMP + I8 CALL MUMPS_730(I8TMP, INT_ARRAY) RETURN END SUBROUTINE MUMPS_723 SUBROUTINE MUMPS_724( INT_ARRAY, I8 ) IMPLICIT NONE INTEGER(8), intent(in) :: I8 INTEGER, intent(inout) :: INT_ARRAY(2) INTEGER(8) :: I8TMP CALL MUMPS_729(I8TMP, INT_ARRAY) I8TMP = I8TMP - I8 CALL MUMPS_730(I8TMP, INT_ARRAY) RETURN END SUBROUTINE MUMPS_724 FUNCTION MUMPS_815(WHICH) LOGICAL :: MUMPS_815 CHARACTER :: WHICH*(*) LOGICAL :: PTSCOTCH=.FALSE., PARMETIS=.FALSE. #if defined(ptscotch) PTSCOTCH = .TRUE. #endif #if defined(parmetis) PARMETIS = .TRUE. #endif SELECT CASE(WHICH) CASE('ptscotch','PTSCOTCH') MUMPS_815 = PTSCOTCH CASE('parmetis','PARMETIS') MUMPS_815 = PARMETIS CASE('both','BOTH') MUMPS_815 = PTSCOTCH .AND. PARMETIS CASE('any','ANY') MUMPS_815 = PTSCOTCH .OR. PARMETIS CASE default write(*,'("Invalid input in MUMPS_815")') END SELECT RETURN END FUNCTION MUMPS_815 mumps-4.10.0.dfsg/src/dmumps_part6.F0000644000175300017530000046255611562233066017446 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE DMUMPS_324(A, LDA, NPIV, NBROW, K50 ) IMPLICIT NONE INTEGER LDA, NPIV, NBROW, K50 DOUBLE PRECISION A(int(LDA,8)*int(NBROW+NPIV,8)) 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_324 SUBROUTINE DMUMPS_651(A, LDA, NPIV, NCONTIG ) IMPLICIT NONE INTEGER NCONTIG, NPIV, LDA DOUBLE PRECISION A(NCONTIG*LDA) 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_651 SUBROUTINE DMUMPS_652( 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(ALLOW_NON_INIT) 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(ALLOW_NON_INIT) 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_652 SUBROUTINE DMUMPS_705( 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(ALLOW_NON_INIT) 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) 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(ALLOW_NON_INIT) IF (.NOT. COMPRESSCB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_705 SUBROUTINE DMUMPS_140( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, & UU, NNEG, NPVW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS ) USE DMUMPS_OOC IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, 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(30) INTEGER INOPV, IFINB, NFRONT, NPIV, NBOLKJ, & NBTLKJ,IBEG_BLOCK INTEGER NASS, NEL1, IFLAG_OOC INTEGER :: LDA DOUBLE PRECISION UUTEMP INCLUDE 'mumps_headers.h' EXTERNAL DMUMPS_222, DMUMPS_234, & DMUMPS_230, DMUMPS_226, & DMUMPS_237 LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVSIZ,IWPOSP2 INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY LOGICAL POSTPONE_COL_UPDATE, IS_MAXFROMM_AVAIL DOUBLE PRECISION MAXFROMM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L INTEGER PP_LastPIVRPTRFilled IS_MAXFROMM_AVAIL = .FALSE. 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 POSTPONE_COL_UPDATE = (UUTEMP == 0.0D0 .AND. KEEP(201).NE.1) IBEG_BLOCK = 1 NFRONT = IW(IOLDPS+KEEP(IXSZ)) LDA = NFRONT NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IF (KEEP(201).EQ.1) THEN IDUMMY = -8765 CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L 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+KEEP(IXSZ): & IOLDPS+5+NFRONT+KEEP(IXSZ)+NFRONT) ENDIF IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) UUTEMP = UU 50 CONTINUE CALL DMUMPS_222(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & INOPV, NNEG, IFLAG,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, KEEP(IXSZ), & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL) 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+KEEP(IXSZ))+6+KEEP(IXSZ) & +IW(IOLDPS+5+KEEP(IXSZ)) PIVNUL_LIST(KEEP(109)) = IW(IWPOSP2) ENDIF ENDIF IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF CALL DMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, POSTPONE_COL_UPDATE, & ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG) GOTO 500 END IF IF (INOPV.EQ.2) THEN CALL DMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), & POSTPONE_COL_UPDATE, & KEEP,KEEP8) GOTO 50 ENDIF NPVW = NPVW + PIVSIZ IF (NASS.LE.1) THEN CALL DMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 GO TO 500 ENDIF CALL DMUMPS_226(IBEG_BLOCK, & NFRONT, NASS, N,INODE,IW,LIW,A,LA, & LDA, POSTPONE_COL_UPDATE, IOLDPS, & POSELT,IFINB, & NBTLKJ,PIVSIZ, KEEP(IXSZ),MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0D0), & KEEP(253) ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6 IW(IWPOSP2+NFRONT+KEEP(IXSZ)) = -IW(IWPOSP2+NFRONT+KEEP(IXSZ)) ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ IF (IFINB.EQ.0) GOTO 50 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV IF (KEEP(201).EQ.1) THEN IF (IFINB.EQ.-1) THEN MonBloc%Last = .TRUE. ELSE MonBloc%Last = .FALSE. ENDIF MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_688( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG .LT. 0 ) RETURN ENDIF CALL DMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), & POSTPONE_COL_UPDATE, & KEEP,KEEP8) IF (IFINB.EQ.-1) THEN CALL DMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG) & GOTO 500 ENDIF GO TO 50 500 CONTINUE IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) LAST_CALL=.TRUE. CALL DMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG < 0 ) RETURN CALL DMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE DMUMPS_140 SUBROUTINE DMUMPS_222 & (NFRONT,NASS,N,INODE,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) #if defined (PROFILE_BLAS_ASS_G) USE DMUMPS_LOAD #endif USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV, & IOLDPS, NNEG 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(30) 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 DOUBLE PRECISION RMAX,AMAX,TMAX,TOL DOUBLE PRECISION MAXPIV DOUBLE PRECISION PIVNUL DOUBLE PRECISION FIXA, CSEUIL DOUBLE PRECISION PIVOT,DETPIV PARAMETER(TOL = 1.0D-20) 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,NASSW,IPIV INTEGER NPIVP1,K 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) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL DMUMPS_667(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 NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL DMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF GO TO 420 ENDIF AMAX = RZERO JMAX = 0 IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM > PIVNUL .AND. abs(PIVOT) > TOL) THEN IF ( abs(PIVOT) .GT. max(UULOC*MAXFROMM,SEUIL) ) THEN IF (PIVOT .LT. RZERO) NNEG = NNEG+1 IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, NASSW - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 IF ( (NFRONT - KEEP(253) - NASSW).GE.300 ) THEN OMP_FLAG = .TRUE. ELSE OMP_FLAG = .FALSE. ENDIF DO J=1, NFRONT - KEEP(253) - NASSW J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO 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, NASSW - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,NFRONT - NASSW A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN IF(SEUIL .GT. epsilon(SEUIL)) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL NNEG = NNEG+1 ENDIF PIVOT = A(POSPV1) KEEP(98) = KEEP(98)+1 GO TO 415 ENDIF ENDIF ENDIF IF (max(AMAX,abs(PIVOT)).LE.TOL) GO TO 460 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN IF (PIVOT .LT. ZERO) NNEG = NNEG+1 IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (AMAX.LE.TOL) GO TO 460 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 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 = (NFRONT-JMAX-KEEP(253). GE. 300) DO K = 1, NFRONT - JMAX - KEEP(253) JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 OMP_FLAG = (NFRONT-JMAX-KEEP(253). GE. 300) DO K = 1, NFRONT-JMAX-KEEP(253) JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO 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 ) GOTO 460 ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_762(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 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) THEN GOTO 416 ENDIF CALL DMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDA, NFRONT, 1, KEEP(219), KEEP(50), & KEEP(IXSZ)) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL DMUMPS_680( 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 (NASSW.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_222 SUBROUTINE DMUMPS_680( 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_680!" 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_680 SUBROUTINE DMUMPS_226(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW, & A,LA,LDA, POSTPONE_COL_UPDATE, & IOLDPS,POSELT,IFINB,LKJIB,PIVSIZ,XSIZE, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & KEEP253) IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB, & NPBEG, IBEG_BLOCK INTEGER LDA INTEGER(8) :: LA INTEGER(8) :: NFRONT8 DOUBLE PRECISION A(LA) LOGICAL POSTPONE_COL_UPDATE INTEGER IW(LIW) DOUBLE PRECISION VALPIV 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 :: MAXFROMMTMP INTEGER IOLDPS, NCB1 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NPIV,JROW2 INTEGER NEL2,NEL INTEGER XSIZE DOUBLE PRECISION ONE, ZERO 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 = IW(IOLDPS+1+XSIZE) NPIV_NEW = NPIV + PIVSIZ NEL = NFRONT - NPIV_NEW IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. JROW2 = IW(IOLDPS+3+XSIZE) NPBEG = IBEG_BLOCK NEL2 = JROW2 - NPIV_NEW IF (NEL2.EQ.0) THEN IF (JROW2.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) A(APOS) = VALPIV 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 (POSTPONE_COL_UPDATE) THEN NCB1 = NASS - JROW2 ELSE NCB1 = NFRONT - JROW2 ENDIF IF (.NOT. IS_MAX_USEFUL) THEN 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 ELSE MAXFROMMTMP=0.0D0 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 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 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) A(POSPV2) = A(POSPV1)/DETPIV A(POSPV1) = SWOP/DETPIV A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL dcopy(NFRONT-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL dcopy(NFRONT-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 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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 = JROW2+1,NFRONT K1 = JJ K2 = JJ+1_8 MULT1 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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_226 SUBROUTINE DMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT) IMPLICIT NONE INTEGER NFRONT,N,INODE,LIW INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) DOUBLE PRECISION VALPIV INTEGER (8) :: APOS, POSELT, LPOS, NFRONT8 INTEGER IOLDPS,NEL INTEGER JROW DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 APOS = POSELT VALPIV = ONE/A(APOS) A(APOS) = VALPIV NEL = NFRONT - 1 IF (NEL.EQ.0) GO TO 500 NFRONT8 = int(NFRONT,8) LPOS = APOS + NFRONT8 CALL DMUMPS_XSYR('U',NEL, -VALPIV, & A(LPOS), NFRONT, A(LPOS+1_8), NFRONT) DO JROW = 1,NEL A(LPOS) = VALPIV*A(LPOS) LPOS = LPOS + NFRONT8 END DO 500 CONTINUE RETURN END SUBROUTINE DMUMPS_230 SUBROUTINE DMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT, & POSTPONE_COL_UPDATE, & KEEP,KEEP8 ) IMPLICIT NONE INTEGER NFRONT, NASS,N,LIW, IBEG_BLOCK INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER(8) :: LDA8 INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1, NEL11 INTEGER LBP, HF INTEGER(8) :: LPOS,UPOS,APOS INTEGER LKJIT INTEGER LKJIBOLD, IROW INTEGER I, Block INTEGER BLSIZE LOGICAL POSTPONE_COL_UPDATE DOUBLE PRECISION ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=1.0D0, ALPHA=-1.0D0) LDA8 = int(LDA,8) LKJIBOLD = LKJIB NPIV = IW(IOLDPS+1+KEEP(IXSZ)) JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 NEL11 = NFRONT - NPIV IF ( LKJIW .NE. LKJIB ) THEN NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) LKJIB = min0(LKJIB, NASS - NPIV) ELSE LKJIB = NASS - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = NASS ENDIF IBEG_BLOCK = NPIV + 1 ELSEIF (JROW2.LT.NASS) THEN IBEG_BLOCK = NPIV + 1 IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) LKJIB = min0(LKJIB,NASS-NPIV) ENDIF IF (LKJIW.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF ( NASS - JROW2 > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NASS - JROW2 END IF IF ( NASS - JROW2 .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int(IROW - 1,8) APOS = POSELT + int(IROW - 1,8) * LDA8 + int(JROW2,8) CALL dgemm( 'N','N', IROW + Block - JROW2 - 1, Block, LKJIW, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ENDDO #else DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL dgemm( 'N','N', Block, NASS - IROW + 1, LKJIW, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF LPOS = POSELT + int(NASS,8)*LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG-1,8) * LDA8 + int(JROW2,8) APOS = POSELT + int(NASS,8)*LDA8 + int(JROW2,8) IF ( .NOT. POSTPONE_COL_UPDATE ) THEN CALL dgemm('N', 'N', NEL1, NFRONT-NASS, LKJIW, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) END IF ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_234 SUBROUTINE DMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, NASS, & LDA, NFRONT, LEVEL, K219, K50, XSIZE ) 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 ) INCLUDE 'mumps_headers.h' 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 CALL dswap( NPIVP1 - 1, & A( POSELT + int(NPIVP1-1,8) ), LDA, & A( POSELT + int(IPIV-1,8) ), LDA ) END IF CALL dswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL dswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP CALL dswap( NASS - IPIV, A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF ( LEVEL .eq. 1 ) THEN CALL dswap( NFRONT - NASS, & A( APOS + int(NASS-IPIV+1,8) * LDA8 ), LDA, & A( IDIAG + int(NASS-IPIV+1,8) * LDA8 ), LDA ) END IF 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_319 SUBROUTINE DMUMPS_237(NFRONT,NASS,N,INODE, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG & ) USE DMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,N,INODE,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 INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, I, IROWEND INTEGER I2, I2END, Block2 DOUBLE PRECISION ONE, ALPHA, BETA, ZERO PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO=0.0D0) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(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 DO I = 1, NPIV CALL dcopy( Block, A( LPOS+int(I-1,8) ), LDA, & A( UPOS+int(I-1,8)*LDA8 ), 1 ) CALL dscal( Block, A(POSELT+(LDA8+1_8)*int(I-1,8)), & A( LPOS + int(I - 1,8) ), LDA ) 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_688( & 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_237 SUBROUTINE DMUMPS_320( 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_327( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL DMUMPS_326( & 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_293( 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_281( 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_320 SUBROUTINE DMUMPS_293( 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_293 SUBROUTINE DMUMPS_281( 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_281 SUBROUTINE DMUMPS_327( 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_327 SUBROUTINE DMUMPS_326( 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_326 RECURSIVE SUBROUTINE DMUMPS_274( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD USE DMUMPS_OOC IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mumps_headers.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 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 PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) 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 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL 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 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 MUMPS_275 EXTERNAL MUMPS_275 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 FPERE = -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 ) LAELL = int(NPIV,8) * int(NCOL,8) 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_731(LAELL-LRLUS, IERROR) IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN DMUMPS_274, & REAL WORKSPACE TOO SMALL" GOTO 700 END IF CALL DMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731(LAELL-LRLUS,IERROR) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN DMUMPS_274, & INTEGER WORKSPACE TOO SMALL" IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL ENDIF KEEP8(67) = min(LRLUS, KEEP8(67)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) IF ( NPIV.GT.0 ) THEN IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, MPI_DOUBLE_PRECISION, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF DO WHILE ( NBPROCFILS(STEP(INODE)) .NE. 0 ) BLOCKING = .TRUE. SET_IRECV=.FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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)) 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 ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN DMUMPS_274" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF 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_274" 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 CALL dtrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), NCOL, & A(POSELT+int(NPIV1,8)), NCOL1 ) 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 LPOS = POSELT + int(NPIV1,8) DPOS = POSBLOCFACTO I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(IPIV+I-1) .GT. 0) THEN CALL dscal( NROW1, A(DPOS), A(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(NCOL + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(NCOL + 1,8) OFFDAG = POSPV1+1_8 LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A(POSPV1)*A(LPOS1)+A(OFFDAG)*A(LPOS1+1_8) MULT2 = A(OFFDAG)*A(LPOS1)+A(POSPV2)*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(NCOL + 1,8) I = I+2 ENDIF ENDDO ENDIF 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 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL DMUMPS_688( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN 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 FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * NCOL - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL DMUMPS_190( 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)) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 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_64( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, IERR ) IF (IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & DMUMPS_274" 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_274" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( NPIV .NE. 0 ) DEALLOCATE( UIP21K ) IOLDPS = PTRIST(STEP(INODE)) IF (LASTBL) THEN IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) - & TO_UPDATE_CPT_END 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_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL DMUMPS_62( INODE, DEST, END_NIV2_LDLT, & COMM, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF END IF IF (LASTBL) THEN IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN CALL DMUMPS_759( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE DMUMPS_274 RECURSIVE SUBROUTINE DMUMPS_759( & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE DMUMPS_LOAD 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) 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_S(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 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 (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+XXS)=S_ALL IF (KEEP(214).EQ.1) THEN CALL DMUMPS_314( 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, 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 CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) ENDIF ENDIF IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN CALL DMUMPS_627(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_80( 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_S, COMP, IFLAG, IERROR, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, .FALSE., ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL DMUMPS_314( 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, ITYPE2 & ) ENDIF CALL DMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL DMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP & ) 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_628( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) IF (KEEP(216).EQ.2) THEN CALL DMUMPS_627(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 RETURN END SUBROUTINE DMUMPS_759 SUBROUTINE DMUMPS_141( 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 ) USE DMUMPS_OOC IMPLICIT NONE INCLUDE 'dmumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW INTEGER(8) :: LA DOUBLE PRECISION A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, SLAVEF, & IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IW( LIW ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), ITLOC(N+KEEP(253)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER PTRARW(LPTRAR), PTRAIW(LPTRAR), ND( KEEP(28) ) INTEGER FRERE(KEEP(28)), FILS(N) INTEGER INTARR(max(1,KEEP(14))) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), & PTLUST_S(KEEP(28)), & & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), NBPROCFILS(KEEP(28)), & PROCNODE_STEPS(KEEP(28)), STEP(N) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(max(1,KEEP(13))) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INTEGER(8) :: POSELT INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, NBTLKJ INTEGER NASS, IEND, IOLDPS, LDAFS,allocok, IBEG_BLOCK LOGICAL LASTBL LOGICAL RESET_TO_ONE, TO_UPDATE INTEGER K109_ON_ENTRY INTEGER I,J,JJ,K,IDEB DOUBLE PRECISION UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled EXTERNAL DMUMPS_223, DMUMPS_235, & DMUMPS_227, DMUMPS_294, & DMUMPS_44 LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVSIZ,IWPOSPIV DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0D0)) IF (RESET_TO_ONE) THEN K109_ON_ENTRY = KEEP(109) ENDIF IBEG_BLOCK=1 NB_BLOC_FAC = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST( STEP( INODE )) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) LDAFS = NASS IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) IF (KEEP(201).EQ.1) THEN IDUMMY = -9876 CALL MUMPS_729(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+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ)) & :IOLDPS+5+2*NFRONT+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))) ENDIF ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, & ' integers' IFLAG=-13 IERROR=NASS GO TO 490 END IF 50 CONTINUE IBEGKJI = IBEG_BLOCK CALL DMUMPS_223( & NFRONT,NASS,IBEGKJI, 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) 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+KEEP(IXSZ))+6 & +IW(IOLDPS+5+KEEP(IXSZ)) PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+KEEP(IXSZ)) ENDIF ENDIF IF(INOPV.EQ. 1 .AND. STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF IF (INOPV.GE.1) THEN LASTBL = (INOPV.EQ.1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL DMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEGKJI, IEND, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (INOPV.EQ.1) GO TO 500 IF (INOPV.EQ.2) THEN CALL DMUMPS_235(IBEG_BLOCK, & NASS,N,INODE,IW,LIW,A,LA, & LDAFS, & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP,KEEP8) GOTO 50 ENDIF NPVW = NPVW + PIVSIZ IF (NASS.LE.1) THEN IFINB = -1 IF (NASS == 1) A(POSELT)=ONE/A(POSELT) ELSE CALL DMUMPS_227(IBEG_BLOCK, & NASS, N,INODE,IW,LIW,A,LA, & LDAFS, IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),PIVSIZ,KEEP(IXSZ)) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+1+KEEP(IXSZ))+6+ & IW(IOLDPS+5+KEEP(IXSZ)) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ IF (IFINB.EQ.0) GOTO 50 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN LASTBL = (IFINB.EQ.-1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL DMUMPS_294(COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEGKJI, IEND, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (IFINB.EQ.(-1)) GOTO 500 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IF (KEEP(201).EQ.1) THEN IF (.NOT.RESET_TO_ONE.OR.K109_ON_ENTRY.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_688( & 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 CALL DMUMPS_235(IBEG_BLOCK, & NASS,N,INODE,IW,LIW,A,LA, & LDAFS, & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP,KEEP8) IF (KEEP(201).EQ.1) THEN IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 JJ= IDEB TO_UPDATE=.FALSE. DO K = K109_ON_ENTRY+1, KEEP(109) I = PIVNUL_LIST(K) DO J=JJ,JJ+NASS IF (IW(J).EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN JJ= J J = J-IDEB+1 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE TO_UPDATE=.FALSE. ELSE IF (ICNTL(1).GT.0) THEN write(ICNTL(1),*) ' Internal error related ', & 'to null pivot row detection' ENDIF EXIT ENDIF ENDDO ENDIF K109_ON_ENTRY = KEEP(109) MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_688( & 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 GO TO 50 490 CONTINUE CALL DMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 JJ= IDEB TO_UPDATE=.FALSE. DO K = K109_ON_ENTRY+1, KEEP(109) I = PIVNUL_LIST(K) DO J=JJ,JJ+NASS IF (IW(J).EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN JJ= J J = J-IDEB+1 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE TO_UPDATE=.FALSE. ELSE IF (ICNTL(1).GT.0) THEN write(ICNTL(1),*) ' Internal error related ', & 'to null pivot row detection' ENDIF EXIT ENDIF ENDDO ENDIF IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) LAST_CALL = .TRUE. CALL DMUMPS_688 & ( STRAT, 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 CALL DMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE DMUMPS_141 SUBROUTINE DMUMPS_223( NFRONT, NASS, & IBEGKJI, 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV INTEGER NASS2, IBEGKJI, NNEG INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV 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(30) 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,TOL DOUBLE PRECISION MAXPIV DOUBLE PRECISION PIVOT,DETPIV PARAMETER(TOL = 1.0D-20) INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK 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,NASSW,IPIV INTEGER NPIVP1,ILOC,K,J INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L 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_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEGKJI + 1 TIPIV( ILOC ) = ILOC NASSW = iabs(IW(IOLDPS+3+KEEP(IXSZ))) 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 DMUMPS_762( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL DMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF GO TO 420 ENDIF AMAX = RZERO 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, NASSW - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = max(abs(A(J1)),AMAX) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO IF (KEEP(219).NE.0) THEN RMAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX = RZERO ENDIF DO J=1,NASS - NASSW RMAX = max(abs(A(J1)),RMAX) J1 = J1 + LDAFS8 ENDDO 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, NASSW - IPIV A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO DO J=1,NASS - NASSW A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO VALTMP = max(1.0D10*RMAX, sqrt(huge(RMAX))/1.0D8) A(POSPV1) = VALTMP ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN IF(SEUIL .GT. epsilon(SEUIL)) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL NNEG = NNEG+1 ENDIF PIVOT = A(POSPV1) WRITE(*,*) 'WARNING matrix may be singular' KEEP(98) = KEEP(98)+1 GO TO 415 ENDIF ENDIF ENDIF IF (max(AMAX,abs(PIVOT)) .LE. TOL) GOTO 460 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN IF (A(POSPV1).LT.RZERO) NNEG = NNEG+1 IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (AMAX.LE.TOL) GO TO 460 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 + LDAFS8 DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDAFS8 ENDDO 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 IF (KEEP(219).NE.0) THEN TMAX = max(SEUIL/UULOC,dble(A(APOSMAX+int(JMAX,8)))) ELSE TMAX = SEUIL/UULOC ENDIF IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+int(NASS,8) IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+int(NASS,8) TMAX=max(TMAX,abs(A(JJ))) ENDDO 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 ) GOTO 460 ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF (KEEP(258).NE.0) THEN CALL DMUMPS_762(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 DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEGKJI + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEGKJI + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEGKJI + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF CALL DMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, KEEP(219), KEEP(50), & KEEP(IXSZ)) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL DMUMPS_680( 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 (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE RETURN END SUBROUTINE DMUMPS_223 SUBROUTINE DMUMPS_235( & IBEG_BLOCK, & NASS, N, INODE, & IW, LIW, A, LA, & LDAFS, & IOLDPS, POSELT, & LKJIB_ORIG, LKJIB, LKJIT, KEEP,KEEP8 ) IMPLICIT NONE INTEGER NASS,N,LIW INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER (8) :: POSELT INTEGER (8) :: LDAFS8 INTEGER LDAFS, IBEG_BLOCK INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1 INTEGER HF INTEGER(8) :: LPOS,UPOS,APOS INTEGER LKJIT INTEGER LKJIBOLD, IROW INTEGER J, Block INTEGER BLSIZE DOUBLE PRECISION ONE, ALPHA PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) LKJIBOLD = LKJIB NPIV = IW(IOLDPS+1+KEEP(IXSZ)) JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 IF ( LKJIW .NE. LKJIB ) THEN NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) LKJIB = min0(LKJIB, NASS - NPIV) ELSE LKJIB = NASS - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = NASS ENDIF ELSEIF (JROW2.LT.NASS) THEN IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) ENDIF IBEG_BLOCK = NPIV + 1 IF (LKJIW.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF ( NASS - JROW2 > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NASS - JROW2 END IF IF ( NASS - JROW2 .GT. 0 ) THEN DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDAFS8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDAFS8 + int(IROW - 1,8) APOS = POSELT + int(IROW-1,8) * LDAFS8 + int(IROW - 1,8) DO J=1, Block CALL dgemv( 'T', LKJIW, Block - J + 1, ALPHA, & A( LPOS ), LDAFS, A( UPOS ), LDAFS, & ONE, A( APOS ), LDAFS ) LPOS = LPOS + LDAFS8 APOS = APOS + LDAFS8 + 1_8 UPOS = UPOS + 1_8 END DO LPOS = POSELT + int(IROW-1+Block,8) * LDAFS8 & + int(NPBEG-1,8) UPOS = POSELT + int(NPBEG-1,8) * LDAFS8 + int(IROW-1,8) APOS = POSELT + int( IROW - 1 + Block,8 ) * LDAFS8 & + int(IROW - 1,8) CALL dgemm( 'N','N', Block, NASS - IROW + 1 - Block, LKJIW, & ALPHA, A( UPOS ), LDAFS, & A( LPOS ), LDAFS, ONE, A( APOS ), LDAFS ) END DO END IF END IF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_235 SUBROUTINE DMUMPS_227 & ( IBEG_BLOCK, NASS, N, INODE, IW, LIW, & A, LA, LDAFS, & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,PIVSIZ, & XSIZE) IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER :: LIW DOUBLE PRECISION A(LA) INTEGER IW(LIW) DOUBLE PRECISION VALPIV INTEGER IOLDPS, NCB1 INTEGER LKJIT, IBEG_BLOCK INTEGER NPIV,JROW2 INTEGER(8) :: APOS INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NASS,N,INODE,IFINB,LKJIB,LDAFS, & NPBEG INTEGER NEL2 INTEGER XSIZE DOUBLE PRECISION ONE, ALPHA DOUBLE PRECISION ZERO INTEGER PIVSIZ,NPIV_NEW INTEGER(8) :: IBEG, IEND, IROW INTEGER :: J2 DOUBLE PRECISION SWOP,DETPIV,MULT1,MULT2 PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO=0.0D0) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV = IW(IOLDPS+1+XSIZE) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) ENDIF JROW2 = IW(IOLDPS+3+XSIZE) NPBEG = IBEG_BLOCK NEL2 = JROW2 - NPIV_NEW IF (NEL2.EQ.0) THEN IF (JROW2.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) A(APOS) = VALPIV LPOS = APOS + LDAFS8 CALL dcopy(NASS-NPIV_NEW, A(LPOS), LDAFS, A(APOS+1_8), 1) CALL DMUMPS_XSYR('U', NEL2, -VALPIV, A(LPOS), LDAFS, & A(LPOS+1_8), LDAFS) CALL dscal(NASS-NPIV_NEW, VALPIV, A(LPOS), LDAFS) IF (NEL2.GT.0) THEN K1POS = LPOS + int(NEL2,8)*LDAFS8 NCB1 = NASS - JROW2 CALL dger(NEL2, NCB1 , ALPHA, A(APOS+1_8), 1, & A(K1POS), LDAFS, A(K1POS+1_8), LDAFS) 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) A(POSPV2) = A(POSPV1)/DETPIV A(POSPV1) = SWOP/DETPIV A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV 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 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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 = JROW2+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A(POSPV1)*A(K1)+A(POSPV1+1_8)*A(K2)) MULT2 = - (A(POSPV1+1_8)*A(K1)+A(POSPV2)*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 ENDIF RETURN END SUBROUTINE DMUMPS_227 RECURSIVE SUBROUTINE DMUMPS_263( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER 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) ) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER MUMPS_275 EXTERNAL MUMPS_275 INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok 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 ) LAELL = int(NPIV,8) * int(NCOLU,8) IF ( LRLU .LT. LAELL ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_731(LAELL - LRLUS, IERROR) GOTO 700 END IF CALL DMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731(LAELL - LRLU, IERROR) GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLU) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_DOUBLE_PRECISION, & COMM, IERR ) 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 (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_731(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) ENDIF DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), & SLAVEF ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDDO DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IOLDPS = PTRIST(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAVES_TOT = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAVES_TOT + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 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 FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL DMUMPS_190(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IW( IOLDPS + 6 + KEEP(IXSZ) ) = IW( IOLDPS + 6+ KEEP(IXSZ) ) + 1 IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL DMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 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_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL DMUMPS_62( INODE, DEST, END_NIV2_LDLT, & COMM, 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 CALL DMUMPS_759( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE DMUMPS_263 SUBROUTINE DMUMPS_38( 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_38 RECURSIVE SUBROUTINE DMUMPS_80 & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, & NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & SHIFT_VAL_SON, LDA, 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE DMUMPS_OOC USE DMUMPS_COMM_BUFFER USE DMUMPS_LOAD IMPLICIT NONE INCLUDE 'dmumps_root.h' INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) 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, LDA INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL INVERT 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 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) 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 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 BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 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_80' CALL DMUMPS_44( MYID, SLAVEF, COMM ) 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. INVERT ) 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.INVERT).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. INVERT ) 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. INVERT ) 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. INVERT ) 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 NBPROCFILS( STEP(IROOT) ) = -1 CALL DMUMPS_284(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, IERROR ) IF (IFLAG.LT.0) THEN CALL DMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF ELSE NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT)) - 1 IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_681(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL DMUMPS_580(IERR) ENDIF CALL DMUMPS_507(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_500( & 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_285( 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), INVERT, & 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_285( 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), INVERT, & 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,': Error in b&scbroot: pb compress' WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL DMUMPS_648( 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, INVERT, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_329( 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, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 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_80" CALL DMUMPS_44( MYID, SLAVEF, COMM ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING DMUMPS_80" IFLAG = -20 IERROR = SIZE_MSG CALL DMUMPS_44( MYID, SLAVEF, COMM ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN END SUBROUTINE DMUMPS_80 SUBROUTINE DMUMPS_285( 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, INVERT, & 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 INVERT 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. INVERT ) 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_285 SUBROUTINE DMUMPS_164 &( 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_99( 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 CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. 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_164 SUBROUTINE DMUMPS_165( 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 RETURN END SUBROUTINE DMUMPS_165 SUBROUTINE DMUMPS_99( 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_99 SUBROUTINE DMUMPS_290(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 INTEGER STATUS(MPI_STATUS_SIZE) DOUBLE PRECISION WK( MBLOCK * NBLOCK ) LOGICAL JUPDATE 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 RETURN END SUBROUTINE DMUMPS_290 SUBROUTINE DMUMPS_156(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 INTEGER STATUS(MPI_STATUS_SIZE) DOUBLE PRECISION WK( MBLOCK * NBLOCK ) LOGICAL JUPDATE 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 RETURN END SUBROUTINE DMUMPS_156 SUBROUTINE DMUMPS_284(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, IERROR ) IMPLICIT NONE INCLUDE 'dmumps_root.h' INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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 ), PTRAIW(N), PTRARW( N ) INTEGER INTARR(max(1,KEEP(14))) DOUBLE PRECISION DBLARR(max(1,KEEP(13))) 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_760 ( 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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_284 SUBROUTINE DMUMPS_760 & ( 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_760 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 SUBROUTINE DMUMPS_XSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) CHARACTER UPLO INTEGER INCX, LDA, N DOUBLE PRECISION ALPHA DOUBLE PRECISION A( LDA, * ), X( * ) CALL dsyr( UPLO, N, ALPHA, X, INCX, A, LDA ) RETURN END SUBROUTINE DMUMPS_XSYR mumps-4.10.0.dfsg/src/mumps_io_thread.c0000644000175300017530000004635311562233011020220 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #include "mumps_io_basic.h" #include "mumps_io_err.h" #include "mumps_io_thread.h" #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) /* Exported global variables */ 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; int int_sem_io,int_sem_nb_free_finished_requests,int_sem_nb_free_active_requests,int_sem_stop; int with_sem; struct request_io *io_queue; int first_active,last_active,nb_active; int *finished_requests_inode,*finished_requests_id,first_finished_requests, last_finished_requests,nb_finished_requests,smallest_request_id; int mumps_owns_mutex; int test_request_called_from_mumps; /* Other global variables */ double inactive_time_io_thread; 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; int ierr,_sem_stop; struct timeval start_time,end_time; 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; } int mumps_test_request_th(int* request_id,int *flag){ /* Tests if the request "request_id" has finished. It sets the flag */ /* argument to 1 if the request has finished (0 otherwise) */ int request_pos; 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; } int mumps_low_level_init_ooc_c_th(int* async, int* ierr){ int i, ret_code; char buf[64]; /* 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;i0) & WRITE(ICNTL1,*) MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF LAST_IOREQUEST(TYPEF_ARG) = NEW_IOREQUEST CALL DMUMPS_689(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE DMUMPS_707 SUBROUTINE DMUMPS_675(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_707(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL DMUMPS_707(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_675 SUBROUTINE DMUMPS_696(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_677(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_677(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_696 SUBROUTINE DMUMPS_669(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_731(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_686() ELSE CALL DMUMPS_685() ENDIF RETURN END SUBROUTINE DMUMPS_669 SUBROUTINE DMUMPS_659() 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_659 SUBROUTINE DMUMPS_685() 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_689(OOC_FCT_TYPE_LOC) END SUBROUTINE DMUMPS_685 SUBROUTINE DMUMPS_678(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_707(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_678 SUBROUTINE DMUMPS_686() 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_689(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE DMUMPS_686 SUBROUTINE DMUMPS_706(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_696(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL DMUMPS_689(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_706 SUBROUTINE DMUMPS_709 (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_709 SUBROUTINE DMUMPS_653( 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_653: 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_707(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL DMUMPS_706(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'DMUMPS_653: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL DMUMPS_709 (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_653 END MODULE DMUMPS_OOC_BUFFER mumps-4.10.0.dfsg/src/zmumps_part3.F0000644000175300017530000071444611562233070017462 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C RECURSIVE SUBROUTINE ZMUMPS_210( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 40 ), KEEP(500) INTEGER(8) KEEP8(150) 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(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(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(max(1,KEEP(13))) INTEGER INTARR(max(1,KEEP(14))) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER 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, ISTCHK, ISTCHK_LOC INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER INTEGER NFRONT INTEGER(8) :: SIZFR INTEGER LDA_SON INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, IROW_SON, & NPIV, NROWS_TO_STACK, II, COLLIST INTEGER(8) :: POSROW, SHIFTCB_SON INTEGER NBCOLS_EFF INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP INTEGER ITMP LOGICAL SAME_PROC, COMPRESSCB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE, TYPESPLIT INTEGER KEEP253_LOC INCLUDE 'mumps_headers.h' INTEGER MUMPS_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_810(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 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_210' 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_275( 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_210' 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_210' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN DO WHILE ( PTRIST(STEP( ISON )) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & PDEST_MASTER_ISON, MAITRE_DESC_BANDE, & 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_47( & 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_210' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) 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_47( & 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) DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .EQ. MYID ) THEN NBPROCFILS(STEP(INODE_PERE)) = & NBPROCFILS(STEP(INODE_PERE)) - 1 IF ( PDEST .EQ. PDEST_MASTER ) THEN NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 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_729(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 (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL ZMUMPS_539 & (N, INODE_PERE, 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_123(NELT, FRTPTR, FRTELT, & N, INODE_PERE, 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_47( & 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 (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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE CALL ZMUMPS_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_40(N, INODE_PERE, & 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) EXIT ELSE CALL ZMUMPS_40(N, INODE_PERE, & 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) 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_210" CALL MUMPS_ABORT() ELSE POSROW = PTRAST(STEP(ISON))+SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL ZMUMPS_617(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER GOTO 600 ENDIF ITMP=-9999 IF ( LMAP_LOC-NBROW(1)+1-KEEP253_LOC .NE. 0 ) THEN CALL ZMUMPS_618( & 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_757( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF CALL ZMUMPS_619(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL ZMUMPS_530(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST_S, 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_152(.FALSE., MYID, N, & ISTCHK_LOC, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 ) THEN CALL ZMUMPS_507( 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_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL ZMUMPS_531 & (N, INODE_PERE, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF END IF END DO 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) 95 CONTINUE IF ( PTRIST(STEP(ISON)) .lt.0 .or. & IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) .GT. N ) 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 CALL ZMUMPS_67( 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_210" 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_210" 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_210" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF GO TO 95 END IF END IF END DO ITYPE = MUMPS_330(PROCNODE_STEPS(STEP(ISON)), SLAVEF) IF (KEEP(214) .EQ. 2) THEN CALL ZMUMPS_314( 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, ITYPE & ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL ZMUMPS_626( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP &) 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_44( MYID, SLAVEF, COMM ) ENDIF RETURN END SUBROUTINE ZMUMPS_210 SUBROUTINE ZMUMPS_211( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE ZMUMPS_COMM_BUFFER 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) 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 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(max(1,KEEP(13))) 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_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER INTARR(max(1,KEEP(14))) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER 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 INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL COMPRESSCB INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_211' 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_211' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_275( & 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_211' 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_47( & 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_211' 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_47( & 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 NBPROCFILS(STEP(INODE_PERE))=NBPROCFILS(STEP(INODE_PERE))-1 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 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_211 ', 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 DO II = 1,NROWS_TO_STACK IROW_SON=PERM(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_47( & 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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_617(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during ZMUMPS_211" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253).GT. 0 ) THEN CALL ZMUMPS_618( & A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253), & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB, & NELIM+NBROW(1)) ELSE CALL ZMUMPS_757(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF CALL ZMUMPS_619(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL ZMUMPS_530(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST_S, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 ) THEN CALL ZMUMPS_507( 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_500( & 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 CALL ZMUMPS_67(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_211" 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_211" 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_211" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_211' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_152(.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_44(MYID, SLAVEF, COMM ) RETURN END SUBROUTINE ZMUMPS_211 SUBROUTINE ZMUMPS_93(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR) USE ZMUMPS_LOAD USE ZMUMPS_OOC 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 INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZECB, IAPOS, I LOGICAL MOVEPTRAST 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) 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_724( 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_576(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in ZMUMPS_576' 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 ELSE POSFAC = POSFAC - SIZECB LRLU = LRLU + SIZECB LRLUS = LRLUS + SIZECB - SIZE_INPLACE ENDIF 500 CONTINUE CALL ZMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE,KEEP,KEEP8,LRLU) RETURN END SUBROUTINE ZMUMPS_93 SUBROUTINE ZMUMPS_314( 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, 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) 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 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) ) 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_729(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 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL ZMUMPS_688 & ( 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_731(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL ZMUMPS_94( N,KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress Stack_band:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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)) IF(KEEP(201).NE.2)THEN CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLU) ELSE CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI+XXI)=LREQI CALL MUMPS_730(LREQA, IW(POSI+XXR)) CALL MUMPS_730(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXS)=-9999 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_576(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in ZMUMPS_576' IERROR=0 GOTO 700 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLU) 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_190(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL ZMUMPS_190(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE ZMUMPS_314 SUBROUTINE ZMUMPS_626( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) IMPLICIT NONE include 'mumps_headers.h' INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB 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_152(.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_626 SUBROUTINE ZMUMPS_214( KEEP,KEEP8, & MYID, N, NELT, LNA, NZ, NA_ELT, 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, NZ, NA_ELT INTEGER(8), INTENT(OUT) :: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES 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, ZMUMPS_LBUFR_BYTES, ZMUMPS_LBUF 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 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 + int(KEEP(13),8) 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 + int(KEEP(14),8) 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 NBRECORDS = min(KEEP(39), NZ) ELSE NBRECORDS = min(KEEP(39), NA_ELT) 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_BYTES = KEEP( 44 ) * KEEP( 35 ) ZMUMPS_LBUFR_BYTES = max( ZMUMPS_LBUFR_BYTES, & 100000 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF ZMUMPS_LBUFR_BYTES = ZMUMPS_LBUFR_BYTES & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUFR_BYTES)/100D0) NB_BYTES = NB_BYTES + int(ZMUMPS_LBUFR_BYTES,8) ZMUMPS_LBUF = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 43 ) * KEEP( 35 )) ) ZMUMPS_LBUF = max( ZMUMPS_LBUF, 100000 ) ZMUMPS_LBUF = ZMUMPS_LBUF & + int( 2.0D0 * dble(max(PERLU,0))* & dble(ZMUMPS_LBUF)/100D0) ZMUMPS_LBUF = max(ZMUMPS_LBUF, ZMUMPS_LBUFR_BYTES) NB_BYTES = NB_BYTES + int(ZMUMPS_LBUF,8) 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 + 5_8 * NSTEPS8 + 3_8 NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI 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_214 SUBROUTINE ZMUMPS_757(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_757 SUBROUTINE ZMUMPS_618( & 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_618 SUBROUTINE ZMUMPS_710 (id, NB_INT,NB_CMPLX ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 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%POIDS)) NB_INT=NB_INT+size(id%POIDS) 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) 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%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)) & NB_INT=NB_INT+size(id%POSINRHSCOMP) IF (associated(id%MEM_SUBTREE)) & NB_INT=NB_INT+size(id%MEM_SUBTREE) 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%COST_TRAV)) NB_INT=NB_INT+size(id%COST_TRAV) 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) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR) 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%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)) NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA)) 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_CMPLX = NB_CMPLX + NB_REAL/2_8 RETURN END SUBROUTINE ZMUMPS_710 SUBROUTINE ZMUMPS_756(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 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 RETURN END SUBROUTINE ZMUMPS_756 SUBROUTINE ZMUMPS_22( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8, & 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) 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_22", & 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_730(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_632(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL ZMUMPS_627(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_627(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_630( 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_724(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_94(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ)) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... alloc_cb', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF DONE = .TRUE. COMP = COMP + 1 ENDIF ENDIF IF (IWPOSCB-IWPOS+1 .LT. LREQ) THEN IF (DONE) GOTO 600 CALL ZMUMPS_94(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ)) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... alloc_cb', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF COMP = COMP + 1 IF (IWPOSCB-IWPOS+1 .LT. LREQ) GOTO 600 ENDIF IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_22",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_22",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_730(LREQCB, IW(IWPOSCB+1+XXR)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF KEEP8(67) = min(LRLUS, KEEP8(67)) #if ! defined(OLD_LOAD_MECHANISM) CALL ZMUMPS_471(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #else #if defined (CHECK_COHERENCE) CALL ZMUMPS_471(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #else CALL ZMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #endif #endif RETURN 600 IFLAG = -8 IERROR = LREQ RETURN 620 IFLAG = -9 CALL MUMPS_731(LREQCB_EFF - LRLUS, IERROR) RETURN END SUBROUTINE ZMUMPS_22 SUBROUTINE ZMUMPS_244(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) USE ZMUMPS_LOAD 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(*) 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 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))) INTEGER INTARR(max(1,KEEP(14))) COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) DOUBLE PRECISION SEUIL, SEUIL_LDLT_NIV2 INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INTEGER MUMPS_275 EXTERNAL MUMPS_275 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) 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 IPTRLU = LRLU NTOTPV = 0 NMAXNPIV = 0 IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_362(N, LEAF, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL ZMUMPS_506(POOL, LPOOL, LEAF) CALL ZMUMPS_555(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_275( PROCNODE_STEPS(STEP(KEEP(38))), SLAVEF ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF CALL ZMUMPS_251(N,IW,LIW,A,LA,IW1(NSTK),IW1(NBPROCFILS), & INFO(1),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, INFO(2), 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) POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN KEEP8(31) = POSFAC ENDIF KEEP(32) = IWPOS CALL MUMPS_735(KEEP8(31), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) 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 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), INFO(12), & 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/ & ' --- (12) NUMBER OF OFF DIAGONAL PIVOTS =',I15/ & ' --- (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) 99990 FORMAT(/ ' NUMBER OF MSGS RECVD FOR DYNAMIC LOAD =',I15) END SUBROUTINE ZMUMPS_244 SUBROUTINE ZMUMPS_269( MYID,KEEP,KEEP8, & 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) 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_22( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, 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_269 SUBROUTINE ZMUMPS_270( 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_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, 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) 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_S(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), PTRARW(N), PTRAIW(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) 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_275 EXTERNAL numroc, MUMPS_275 IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_275( 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_270" CALL MUMPS_ABORT() ENDIF ENDIF PTLUST_S(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_94( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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_S(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST_S( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_730( LREQA, IW(POSHEAD + XXR)) IW( POSHEAD + XXS )=-9999 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_731(LREQA - LRLUS, IERROR) GOTO 700 END IF CALL ZMUMPS_94( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB2 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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_S(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = max(POSFAC-1_8,1_8) PTRFAC (STEP(IROOT)) = max(POSFAC-1_8,1_8) 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) CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) POSHEAD = PTLUST_S( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_730( LREQA, IW(POSHEAD + XXR)) IW( POSHEAD + XXS ) = S_NOTFREE 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 ( KEEP( 50 ) .eq. 0 .OR. KEEP(50) .eq. 2 ) THEN OPELIW = OPELIW + ( dble(2*TOT_ROOT_SIZE) * & dble(TOT_ROOT_SIZE) * dble(TOT_ROOT_SIZE ) / dble(3) & - 0.5d0 * dble( TOT_ROOT_SIZE ) * dble( TOT_ROOT_SIZE ) & - dble( TOT_ROOT_SIZE ) / dble( 6 ) ) & / dble( root%NPROW * root%NPCOL ) ELSE OPELIW = OPELIW + ( dble(TOT_ROOT_SIZE) * & dble( TOT_ROOT_SIZE) * & dble( TOT_ROOT_SIZE + 1 ) ) & / dble( 3 * root%NPROW * root%NPCOL ) END IF 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_756(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL ZMUMPS_96( 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_152(.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 ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_681(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL ZMUMPS_580(IERR) ENDIF CALL ZMUMPS_507( 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_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE ZMUMPS_270 SUBROUTINE ZMUMPS_96 &( 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_96 INTEGER FUNCTION ZMUMPS_505(KEEP,KEEP8) IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) ZMUMPS_505 = KEEP(28) + 1 + 3 RETURN END FUNCTION ZMUMPS_505 SUBROUTINE ZMUMPS_506(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_506 SUBROUTINE ZMUMPS_507 & (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_170 LOGICAL MUMPS_170, 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_170(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_514(INODE,1) ENDIF ENDIF IF ( MUMPS_170(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))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)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)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_507 LOGICAL FUNCTION ZMUMPS_508(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) ZMUMPS_508 = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION ZMUMPS_508 SUBROUTINE ZMUMPS_509( 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_167, MUMPS_283, ZMUMPS_508 LOGICAL MUMPS_167, MUMPS_283, ZMUMPS_508 EXTERNAL MUMPS_275 INTEGER MUMPS_275 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 #if defined(POOL_EXTRACT_MNG) INTEGER POS_TO_EXTRACT #endif 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_509: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( ZMUMPS_508(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in ZMUMPS_509" 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_509" 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_561(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_820(FLAG_MEM) IF(FLAG_MEM)THEN CALL ZMUMPS_561(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_167( PROCNODE(STEP(INODE_EFF)), SLAVEF) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL ZMUMPS_513(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_283( PROCNODE(STEP(INODE_EFF)), & SLAVEF)) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL ZMUMPS_513(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in ZMUMPS_509", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL ZMUMPS_520 & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_167( PROCNODE(STEP(INODE)), & SLAVEF) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_283( PROCNODE(STEP(INODE)), & SLAVEF)) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL ZMUMPS_561(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 defined(POOL_EXTRACT_MNG) IF(KEEP(76).EQ.4)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.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 #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ELSE IF(DEPTH_FIRST_LOAD(STEP(POOL(LPOOL-2-I))).LT. & DEPTH_FIRST_LOAD(STEP(NODE_TO_EXTRACT))) & THEN POS_TO_EXTRACT=I #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ENDIF ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) INODE = NODE_TO_EXTRACT #else INODE = INODE_EFF #endif DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ENDIF IF(KEEP(76).EQ.5)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.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 #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ELSE IF(COST_TRAV(STEP(POOL(LPOOL-2-I))).GT. & COST_TRAV(STEP(NODE_TO_EXTRACT)))THEN POS_TO_EXTRACT=I #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ENDIF ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) INODE = NODE_TO_EXTRACT #else INODE = INODE_EFF #endif DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ENDIF #endif 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_820(FLAG_MEM) IF(FLAG_MEM)THEN CALL ZMUMPS_561(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_819(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_514(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_509 SUBROUTINE ZMUMPS_552(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_275 EXTERNAL MUMPS_275 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_818(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL ZMUMPS_818(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_554(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_819(INODE) #if ! defined(NOT_ATM_POOL_SPECIAL) ELSE ENDIF #endif END SUBROUTINE ZMUMPS_552 SUBROUTINE ZMUMPS_561(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_167 LOGICAL MUMPS_167 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_552(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_553(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_167(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_819(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_561 SUBROUTINE ZMUMPS_574 & ( 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_574 SUBROUTINE ZMUMPS_128(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, PTRAR, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & ELTNOD, NSLAVES, & XNODEL, NODEL) IMPLICIT NONE INTEGER N,NELT,LIW,IORD, SIZE_SCHUR, NSLAVES INTEGER PTRAR(N,3), NFSIZ(N), FILS(N), FRERE(N) INTEGER ELTPTR(NELT+1) INTEGER XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) INTEGER ELTVAR(ELTPTR(NELT+1)-1) INTEGER IKEEP(N,3) INTEGER LISTVAR_SCHUR(SIZE_SCHUR) INTEGER INFO(40), ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER ELTNOD(NELT) INTEGER K,I,L1,L2,IWFR,NCMPA,LLIW,IFSON,IN INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER NZ, allocok, ITEMP LOGICAL PROK, NOSUPERVAR INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER OPT_METIS_SIZE, NUMFLAG PARAMETER(OPT_METIS_SIZE = 8, NUMFLAG = 1) INTEGER OPTIONS_METIS(OPT_METIS_SIZE) INTEGER IDUM EXTERNAL MUMPS_197, ZMUMPS_130, ZMUMPS_131, & ZMUMPS_129, ZMUMPS_132, & ZMUMPS_133, ZMUMPS_134, & ZMUMPS_199, & ZMUMPS_557, ZMUMPS_201 #if defined(OLDDFS) EXTERNAL ZMUMPS_200 #endif ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW RETURN ENDIF MPRINT= ICNTL(3) PROK = (MPRINT.GT.0) LP = ICNTL(1) MP = ICNTL(3) 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) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) 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) IF ( IORD == 5 ) THEN IF (LIW .LT. N+N+1) THEN INFO(1)= -2002 INFO(2) = LIW RETURN ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2*N ) THEN INFO(1)= -2002 INFO(2) = LIW RETURN END IF ELSE IF ( LIW .LT. 4*N+4 ) THEN INFO(1)= -2002 INFO(2) = LIW RETURN END IF ENDIF #if defined(metis) || defined(parmetis) ENDIF #endif IDUM=0 CALL ZMUMPS_258(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_129(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), IW(L1)) ELSE CALL ZMUMPS_130(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), 4*N+4, IW(L1)) ENDIF LLIW = max(NZ,N) ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF IF (NOSUPERVAR) THEN CALL ZMUMPS_132(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) ELSE CALL ZMUMPS_131(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_162(N, LLIW, PTRAR, IWFR, PTRAR(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), PTRAR(1,3), & 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_128",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_23(N, LLIW, PTRAR, IWFR, PTRAR(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), PTRAR(1,3)) ENDIF ELSE #if defined(metis) || defined(parmetis) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS ' ENDIF CALL ZMUMPS_129(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), IW(L1)) LLIW = max(NZ,N) ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF CALL ZMUMPS_538(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, IW(L2), PTRAR(1,2), & IW(L1), IWFR) OPTIONS_METIS(1) = 0 CALL METIS_NODEND(N, IW(L2), IW2(1), NUMFLAG, OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) 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_133(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, PTRAR(1,2), IW(L1)) LLIW = NZ+N ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF CALL ZMUMPS_134(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) 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_128",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL ZMUMPS_199(N, PTRAR, IW2, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP) ENDIF #if defined(OLDDFS) CALL ZMUMPS_200(N, PTRAR, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else CALL ZMUMPS_557(N, PTRAR, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, PTRAR(1,2), & INFO(6), FILS, FRERE, PTRAR(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_201(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_209( 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_510(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 IF ( huge(KEEP8(79)) / K79REF + 1_8 .GE. int(NSLAVES,8) ) THEN KEEP8(79)=huge(KEEP8(79)) ELSE KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF ENDIF IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN CALL ZMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0) .AND. (NSLAVES.GE.ICNTL(13))) IF (SPLITROOT) THEN CALL ZMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) RETURN 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 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) 90 CONTINUE DEALLOCATE(IW) 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_128 SUBROUTINE ZMUMPS_258( 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_258 ***') END SUBROUTINE ZMUMPS_258 SUBROUTINE ZMUMPS_129(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD, 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 DO I = 1,N NZ = NZ + LEN(I) ENDDO RETURN END SUBROUTINE ZMUMPS_129 SUBROUTINE ZMUMPS_538(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER LEN(N) INTEGER IPE(N+1) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1 DO I = 1,N IWFR = IWFR + LEN(I) 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_538 SUBROUTINE ZMUMPS_132(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER LEN(N) INTEGER IPE(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 DO I = 1,N IWFR = IWFR + LEN(I) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0 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 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_132 SUBROUTINE ZMUMPS_133(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD 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 DO I = 1,N NZ = NZ + LEN(I) ENDDO RETURN END SUBROUTINE ZMUMPS_133 SUBROUTINE ZMUMPS_134(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER IPE(N), LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0 DO I = 1,N IWFR = IWFR + LEN(I) + 1 IPE(I) = IWFR ENDDO IWFR = IWFR + 1 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 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = IPE(I) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0 ENDDO RETURN END SUBROUTINE ZMUMPS_134 SUBROUTINE ZMUMPS_25( 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 PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 INTEGER ELT, I, K, IPTRI, IPTRR, NVAR INTEGER TYPE_PARALL, ITYPE, IRANK TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_330( PROCNODE(abs(STEP(I))), SLAVEF ) IRANK = MUMPS_275( 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 IPTRI = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI IPTRI = IPTRI + NVAR ENDDO PTRAIW( NELT+1 ) = IPTRI KEEP( 14 ) = IPTRI - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + NVAR*NVAR ENDDO PTRARW( NELT+1 ) = IPTRR ELSE IPTRR = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + (NVAR*(NVAR+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR = 1 DO ELT = 1,NELT NVAR = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + NVAR*NVAR ENDDO PTRARW( NELT+1 ) = IPTRR ELSE IPTRR = 1 DO ELT = 1,NELT NVAR = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + (NVAR*(NVAR+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR ENDIF ENDIF KEEP( 13 ) = IPTRR - 1 RETURN END SUBROUTINE ZMUMPS_25 SUBROUTINE ZMUMPS_120( N, NELT, ELTPROC, SLAVEF, PROCNODE ) IMPLICIT NONE INTEGER N, NELT, SLAVEF INTEGER PROCNODE( N ), ELTPROC( NELT ) INTEGER ELT, I, ITYPE, MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_330(PROCNODE(I),SLAVEF) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_275(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_120 SUBROUTINE ZMUMPS_153(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER FRERE(N), FILS(N), NA(N), NE(N) INTEGER FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER XNODEL(N+1), NODEL(NELNOD) INTEGER TNSTK( N ), IPOOL( N ) INTEGER I, K, IFATH INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN 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 file ZMUMPS_153 ' 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 RETURN END SUBROUTINE ZMUMPS_153 SUBROUTINE ZMUMPS_130(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW 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_315 LP = 6 CALL ZMUMPS_315(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_315. 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 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 + LEN(I) ENDDO RETURN END SUBROUTINE ZMUMPS_130 SUBROUTINE ZMUMPS_131(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER IPE(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + LEN(I) IPE(I) = IWFR ELSE IPE(I) = 0 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_131 SUBROUTINE ZMUMPS_315(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_316 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_316(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_315: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I8) END SUBROUTINE ZMUMPS_315 SUBROUTINE ZMUMPS_316( 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_316 SUBROUTINE ZMUMPS_36( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & & NSTK_S,NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER NELT,N,LIW,NSTEPS INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER IFLAG,IERROR,INODE,MAXFRW, & IWPOS, IWPOSCB, COMP INTEGER IDUMMY(1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(NELT+1), PTRAIW(NELT+1), ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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) A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER INTARR(max(1,KEEP(14))) COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) 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 INCLUDE 'mumps_headers.h' LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER MUMPS_330 EXTERNAL MUMPS_330 INTEGER LP, HS, HF INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) NFRONT8 INTEGER(8) LAELL8, APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) LSTK8, SIZFR8 #if defined(ALLOW_NON_INIT) INTEGER(8) :: JJ8 #endif INTEGER NBPANELS_L, NBPANELS_U, LREQ_OOC INTEGER SIZFI, NCB INTEGER JJ,J1,J2 INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM,JJ1,J3, & IORG, IBROT INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER AINPUT, & AII, 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, SIZE_ELTI INTEGER II, I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) LOGICAL MUMPS_167, SSARBR EXTERNAL MUMPS_167 DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_170 LOGICAL MUMPS_170 NFS4FATHER = -1 ETATASS = 0 COMPRESSCB=.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (LEVEL.NE.1) THEN write(6,*) 'Error1 in mpi51f_niv1 ' 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 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG LREQ_OOC = 0 IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' 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. IF (KEEP(50).EQ.0) THEN CALL MUMPS_124( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, NFRONT, NFRONT_EFF, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG ) ELSE CALL MUMPS_125( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IF (IFLAG.LT.0) GOTO 300 END IF IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_170(PROCNODE_STEPS(STEP(INODE)), & SLAVEF))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL ZMUMPS_190(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 Write(*,*) ' ERROR 1 during ass_niv1_ELT' GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL ZMUMPS_691(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_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL ZMUMPS_471(SSARBR,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, & LRLU) #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, int(NFRONT -1,8) A(APOS:APOS+JJ8) = ZERO APOS = APOS + NFRONT8 END DO END IF #endif NASS = NASS1 PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST_S(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 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)) LSTK = IW(ISTCHK+KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = IW(ISTCHK + 1+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.LE.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB = & ( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = IW( ISTCHK + 2+KEEP(IXSZ)) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS J1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1) THEN J2 = J1 + 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 J2 = J1 + NELIM - 1 ENDIF OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (J2.GE.J1) THEN DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * NFRONT8 DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 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(J2 - J1 + 1,8) ENDIF CALL ZMUMPS_178(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), J2 - J1 + 1, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) END DO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) END DO IF (NELIM .NE. 0) THEN J3 = J3 - 1 DO JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) END DO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP( ISON )) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL ZMUMPS_152(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_49( & 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_210( 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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP,KEEP8, 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 & ) IF ( IFLAG .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_71( 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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = INTARR(II) IF (KEEP(50).EQ.0) THEN AINPUT = AII + II - J1 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ=J1,J2 APOS2 = ICT12 + int(INTARR(JJ) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ=II,J2 J = INTARR(JJ) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII) AII = AII + 1 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 JJ=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ELSE DO JJ=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+JJ-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF GOTO 500 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_36' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING ZMUMPS_36' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8-LRLUS, IERROR) GOTO 500 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING ZMUMPS_36' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = 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 DURING ZMUMPS_36' ENDIF IFLAG = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING ZMUMPS_36' ENDIF IFLAG = -13 IERROR = NUMSTK 490 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_36 SUBROUTINE ZMUMPS_37( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, & MEM_DISTRIB) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD IMPLICIT NONE INCLUDE 'zmumps_root.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER NELT, N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER(8) LRLU, IPTRLU, LRLUS, POSFAC, LA INTEGER(8) LAELL8 INTEGER JJ INTEGER IFLAG,IERROR,INODE,MAXFRW, & LPOOL, LEAF, & IWPOS, & IWPOSCB, COMP, SLAVEF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(NELT+1), PTRAIW(NELT+1), ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), STEP(N), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PAMASTER(KEEP(28)), & PTRAST(KEEP(28)) 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) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER INTARR(max(1,KEEP(14))) COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) INTEGER MYID, COMM INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF, HF_OLD, NSLAVES_OLD,NCBSON INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC, NBPANELS_L, NBPANELS_U INTEGER NCB INTEGER J1,J2 INTEGER(8) NFRONT8, LAPOS2, POSELT, POSEL1, LDAFS8, & JJ2, IACHK, ICT12, ICT21 #if defined(ALLOW_NON_INIT) INTEGER(8) :: JJ8 #endif INTEGER(8) APOS, APOS2 INTEGER NELIM,LDAFS,JJ1,NPIVS,NCOLS,NROWS, & IORG INTEGER LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER AINPUT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, ISLAVE, PDEST INTEGER ELTI, SIZE_ELTI INTEGER II, ELBEG, NUMELT, I, J, AII LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX logical :: force_cand INTEGER(8) APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NUMORG_SPLIT, TYPESPLIT, & NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER IZERO INTEGER IDUMMY(1) INTEGER PDEST1(1) INTEGER ETATASS PARAMETER( IZERO = 0 ) INTEGER MUMPS_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 INTRINSIC real COMPLEX(kind=8) ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = (0.0D0,0.0D0) ) 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) END DO 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_330(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) END IF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO 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 IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) SIZE_TMP_SLAVES_LIST = CAND( SLAVEF+1, INIV2 ) ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_810 (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 265 ENDIF CALL ZMUMPS_791 ( & 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_472( 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_790 ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) TMP_SLAVES_LIST (1:SIZE_TMP_SLAVES_LIST) & = CAND (1:SIZE_TMP_SLAVES_LIST, INIV2) CALL ZMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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_472( 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_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. IF (KEEP(50).EQ.0) THEN CALL MUMPS_124( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, NFRONT,NFRONT_EFF, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) ELSE CALL MUMPS_125( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IF (IFLAG.LT.0) GOTO 250 ENDIF IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN 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 WRITE(6,*) ' Internal error 2 in fac_ass_elt due', & ' to plitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF CALL MUMPS_ABORT() ELSE CALL ZMUMPS_472( 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 JJ=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+JJ)=IW(IOLDPS+HF_OLD+JJ) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO JJ=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+JJ) = IW(IOLDPS+HF_OLD+JJ) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE Write(*,*) ' ERROR 2 during ass_niv2' GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL ZMUMPS_691(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST_S(STEP(INODE)) = IOLDPS 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+KEEP(IXSZ)) = NFRONT 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_461(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_533(SLAVEF,CAND(SLAVEF+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_533(SLAVEF,SLAVEF-1, & 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) THEN IF(KEEP(50) .EQ. 2) LAELL8 = LAELL8+int(NASS1,8) ENDIF LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE CALL ZMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 CALL ZMUMPS_471(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, &LRLU) POSEL1 = POSELT - LDAFS8 #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, LDAFS8 - 1_8 A(APOS:APOS+JJ8) = ZERO APOS = APOS + LDAFS8 END DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN A(APOS:APOS+LDAFS8-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.LE.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) J1 = ISTCHK + HS + NROWS + NPIVS J2 = J1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) IF (KEEP(50).eq.0) THEN DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * LDAFS8 DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1,8) - 1_8) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE 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 CALL ZMUMPS_178(A, LA, & POSELT, LDAFS, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), NELIM, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) 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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = INTARR(II) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT = AII + II - J1 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ=J1,J2 APOS2 = ICT12 + int(INTARR(JJ) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI 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) THEN IF (KEEP(50).EQ.2) THEN AINPUT=AII DO JJ=II,J2 J=INTARR(JJ) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))=cmplx( & max(dble(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT))), & kind=kind(A) & ) ENDIF AINPUT=AINPUT+1 ENDDO ELSE AII = AII + J2 - II + 1 CYCLE ENDIF ELSE AII = AII + J2 - II + 1 CYCLE ENDIF ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ=II,J2 J = INTARR(JJ) 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(AII) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII))) ENDIF AII = AII + 1 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 JJ = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-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) DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & 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_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & IW(PDEST), NFRONT, COMM, IERR) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL ZMUMPS_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & IW(PDEST), NFRONT, COMM, IERR) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.) IF ( IFLAG .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST_S(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF END DO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 END DO 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.LE.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_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) IF (PDEST1(1).EQ.MYID) THEN CALL ZMUMPS_211( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8, 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 ) IF ( IFLAG .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL ZMUMPS_71( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST_S(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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_49( & 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_210( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, 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 & ) IF ( IFLAG .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_71( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST_S(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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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)) END DO GOTO 500 250 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION during assembly' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 GOTO 490 265 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DYNAMIC ALLOCATION during assembly' ENDIF IFLAG = -13 IERROR = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_37' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, WORKSPACE TOO SMALL DURING ZMUMPS_37' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8 - LRLUS, IERROR) 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_37' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = 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_37' ENDIF IFLAG = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SENDBUFFER TOO SMALL (2) DURING ZMUMPS_37' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECVBUFFER TOO SMALL (2) DURING ZMUMPS_37' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 490 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_37 SUBROUTINE ZMUMPS_123( & 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), PTRARW(NELT+1), & PTRAIW(NELT+1) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) COMPLEX(kind=8) A(LA), & DBLARR(max(1,KEEP(13))) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSELT, APOS2, ICT12, APOS INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,I,J,JPOS,NASS,JJ, & IN,AINPUT,J1,J2,IJROW,ILOC, & ELBEG, NUMELT, ELTI, SIZE_ELTI, IPOS, & IPOS1, IPOS2, AII, II, IELL INTEGER :: K1RHS, K2RHS, JFirstRHS 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 A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = & ZERO 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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = ITLOC(INTARR(II)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT = AII + II - J1 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ = J1, J2 JPOS = ITLOC(INTARR(JJ)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI END DO ELSE IF ( I .EQ. 0 ) THEN AII = AII + J2 - II + 1 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 JJ=II,J2 AII = AII + 1 J = ITLOC(INTARR(JJ)) 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(AII-1) 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(AII-1) 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 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_123 SUBROUTINE ZMUMPS_126( & N, NELT, NA_ELT, & COMM, MYID, SLAVEF, & IELPTR_LOC, RELPTR_LOC, & ELTVAR_LOC, ELTVAL_LOC, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NELT, NA_ELT 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 IELPTR_LOC( NELT + 1 ), RELPTR_LOC( NELT + 1 ) INTEGER ELTVAR_LOC( max(1,KEEP(14)) ) COMPLEX(kind=8) ELTVAL_LOC( max(1,KEEP(13)) ) 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 STATUS( MPI_STATUS_SIZE ), IERR_MPI INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER RECV_IELTPTR, RECV_RELTPTR INTEGER IELTPTR, RELTPTR, INODE 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, K, NB_REC, IREC INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER IVALPTR 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, DIMENSION( : ), ALLOCATABLE :: ELROOTPOS 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 ) 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 = min(KEEP(39),NA_ELT) 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( ELROOTPOS( 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_276( 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_IELTPTR = 1 RECV_RELTPTR = 1 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR = 1 RELPTR_LOC(1) = 1 DO IEL = 1, NELT IELTPTR = id%ELTPTR( IEL ) SIZEI = id%ELTPTR( IEL + 1 ) - IELTPTR 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 ELROOTPOS( NBELROOT ) = RELTPTR GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL ZMUMPS_288( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR ), id%A_ELT( RELTPTR ), & 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_IELTPTR: RECV_IELTPTR + SIZEI - 1 ) & = id%ELTVAR( IELTPTR: IELTPTR + SIZEI - 1 ) RECV_IELTPTR = RECV_IELTPTR + SIZEI IF ( KEEP(52) .ne. 0 ) THEN ELTVAL_LOC( RECV_RELTPTR: RECV_RELTPTR + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR = RECV_RELTPTR + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL ZMUMPS_127( & id%ELTVAR(IELTPTR), & id%A_ELT (RELTPTR), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL ZMUMPS_127( & id%ELTVAR(IELTPTR), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR = RELTPTR + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC( IEL + 1 ) = RELTPTR ELSE RELPTR_LOC( IEL + 1 ) = RECV_RELTPTR ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP(13) = RELTPTR - 1 ELSE KEEP(13) = RECV_RELTPTR - 1 ENDIF IF ( RELTPTR - 1 .ne. id%NA_ELT ) THEN WRITE(*,*) ' ** ERROR ELT DIST: RELPTR - 1 / id%NA_ELT=', & RELTPTR - 1,id%NA_ELT CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR = 1 RELTPTR = 1 SIZEI = 1 SIZER = 1 CALL ZMUMPS_127( & id%ELTVAR(IELTPTR), & id%A_ELT (RELTPTR), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR .eq. IELPTR_LOC( NELT+1 ) & .and. RECV_RELTPTR .eq. RELPTR_LOC( 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_IELTPTR ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR = RECV_IELTPTR + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_DOUBLE_COMPLEX, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR ), MSGLEN, & MPI_DOUBLE_COMPLEX, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR = RECV_RELTPTR + MSGLEN END SELECT FINI = ( RECV_IELTPTR .eq. IELPTR_LOC( NELT+1 ) & .and. RECV_RELTPTR .eq. RELPTR_LOC( 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_276( 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 IVALPTR = ELROOTPOS( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K = 1 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( IVALPTR + K ) ELSE VAL = id%A_ELT( IVALPTR + K ) * & 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_34( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) END IF K = K + 1 END DO END DO END DO CALL ZMUMPS_18( & 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(ELROOTPOS) IF (KEEP(46) .eq. 0 ) THEN DEALLOCATE(RG2LALLOC) ENDIF ENDIF DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE ZMUMPS_126 SUBROUTINE ZMUMPS_127( & 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_127 SUBROUTINE ZMUMPS_213( 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_213 SUBROUTINE ZMUMPS_288( 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_288 SUBROUTINE ZMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, ICNTL, CNTL, & NZ, IRN, IRNhere, JCN, JCNhere, A, Ahere, & NZ_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 ICNTL(40), INFO(40), INFOG(40) 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) 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(in) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(in) :: 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 ZMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (ZMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_AFFECT_MAPPING, & MUMPS_AFFECT_PIVNUL_LIST, & MUMPS_AFFECT_SYM_PERM, & MUMPS_AFFECT_UNS_PERM 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%NZ_loc = NZ_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%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) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NZ) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NZ) IF ( Ahere /= 0 ) mumps_par%A => A(1:NZ) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NZ_loc) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NZ_loc) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NZ_loc) 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) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NZ = mumps_par%NZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_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_AFFECT_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_AFFECT_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_AFFECT_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_AFFECT_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF 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-4.10.0.dfsg/src/smumps_part3.F0000644000175300017530000071250411562233065017450 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C RECURSIVE SUBROUTINE SMUMPS_210( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 40 ), KEEP(500) INTEGER(8) KEEP8(150) 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(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(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(max(1,KEEP(13))) INTEGER INTARR(max(1,KEEP(14))) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER 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, ISTCHK, ISTCHK_LOC INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER INTEGER NFRONT INTEGER(8) :: SIZFR INTEGER LDA_SON INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, IROW_SON, & NPIV, NROWS_TO_STACK, II, COLLIST INTEGER(8) :: POSROW, SHIFTCB_SON INTEGER NBCOLS_EFF INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP INTEGER ITMP LOGICAL SAME_PROC, COMPRESSCB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE, TYPESPLIT INTEGER KEEP253_LOC INCLUDE 'mumps_headers.h' INTEGER MUMPS_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_810(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 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_210' 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_275( 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_210' 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_210' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN DO WHILE ( PTRIST(STEP( ISON )) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & PDEST_MASTER_ISON, MAITRE_DESC_BANDE, & 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_47( & 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_210' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) 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_47( & 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) DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .EQ. MYID ) THEN NBPROCFILS(STEP(INODE_PERE)) = & NBPROCFILS(STEP(INODE_PERE)) - 1 IF ( PDEST .EQ. PDEST_MASTER ) THEN NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 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_729(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 (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL SMUMPS_539 & (N, INODE_PERE, 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_123(NELT, FRTPTR, FRTELT, & N, INODE_PERE, 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_47( & 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 (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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE CALL SMUMPS_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_40(N, INODE_PERE, & 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) EXIT ELSE CALL SMUMPS_40(N, INODE_PERE, & 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) 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_210" CALL MUMPS_ABORT() ELSE POSROW = PTRAST(STEP(ISON))+SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL SMUMPS_617(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER GOTO 600 ENDIF ITMP=-9999 IF ( LMAP_LOC-NBROW(1)+1-KEEP253_LOC .NE. 0 ) THEN CALL SMUMPS_618( & 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_757( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF CALL SMUMPS_619(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL SMUMPS_530(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST_S, 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_152(.FALSE., MYID, N, & ISTCHK_LOC, & PAMASTER(STEP(ISON)), & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) ENDIF IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 ) THEN CALL SMUMPS_507( 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_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL SMUMPS_531 & (N, INODE_PERE, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF END IF END DO 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) 95 CONTINUE IF ( PTRIST(STEP(ISON)) .lt.0 .or. & IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) .GT. N ) 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 CALL SMUMPS_67( 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_210" 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_210" 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_210" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF GO TO 95 END IF END IF END DO ITYPE = MUMPS_330(PROCNODE_STEPS(STEP(ISON)), SLAVEF) IF (KEEP(214) .EQ. 2) THEN CALL SMUMPS_314( 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, ITYPE & ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL SMUMPS_626( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP &) 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_44( MYID, SLAVEF, COMM ) ENDIF RETURN END SUBROUTINE SMUMPS_210 SUBROUTINE SMUMPS_211( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE SMUMPS_COMM_BUFFER 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) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW REAL A( LA ) 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(max(1,KEEP(13))) 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_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER INTARR(max(1,KEEP(14))) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER 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 INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL COMPRESSCB INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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_211' 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_211' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_275( & 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_211' 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_47( & 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_211' 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_47( & 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 NBPROCFILS(STEP(INODE_PERE))=NBPROCFILS(STEP(INODE_PERE))-1 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - 1 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_211 ', 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 DO II = 1,NROWS_TO_STACK IROW_SON=PERM(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_47( & 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_39(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & A(POSROW), PTLUST_S, 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_617(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during SMUMPS_211" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253).GT. 0 ) THEN CALL SMUMPS_618( & A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253), & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB, & NELIM+NBROW(1)) ELSE CALL SMUMPS_757(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF CALL SMUMPS_619(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST_S, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(ISON)) .EQ. 0) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL SMUMPS_530(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST_S, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( NBPROCFILS(STEP(INODE_PERE)) .EQ. 0 ) THEN CALL SMUMPS_507( 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_500( & 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 CALL SMUMPS_67(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_211" 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_211" 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_211" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_211' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_152(.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_44(MYID, SLAVEF, COMM ) RETURN END SUBROUTINE SMUMPS_211 SUBROUTINE SMUMPS_93(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR) USE SMUMPS_LOAD USE SMUMPS_OOC 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 INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZECB, IAPOS, I LOGICAL MOVEPTRAST 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) 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_724( 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_576(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in SMUMPS_576' 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 ELSE POSFAC = POSFAC - SIZECB LRLU = LRLU + SIZECB LRLUS = LRLUS + SIZECB - SIZE_INPLACE ENDIF 500 CONTINUE CALL SMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE,KEEP,KEEP8,LRLU) RETURN END SUBROUTINE SMUMPS_93 SUBROUTINE SMUMPS_314( 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, 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) 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 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) ) 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_729(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 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL SMUMPS_688 & ( 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_731(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL SMUMPS_94( N,KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress Stack_band:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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)) IF(KEEP(201).NE.2)THEN CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLU) ELSE CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI+XXI)=LREQI CALL MUMPS_730(LREQA, IW(POSI+XXR)) CALL MUMPS_730(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXS)=-9999 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_576(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in SMUMPS_576' IERROR=0 GOTO 700 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLU) 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_190(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL SMUMPS_190(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE SMUMPS_314 SUBROUTINE SMUMPS_626( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP & ) IMPLICIT NONE include 'mumps_headers.h' INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB 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_152(.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_626 SUBROUTINE SMUMPS_214( KEEP,KEEP8, & MYID, N, NELT, LNA, NZ, NA_ELT, 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, NZ, NA_ELT INTEGER(8), INTENT(OUT) :: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES 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, SMUMPS_LBUFR_BYTES, SMUMPS_LBUF 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 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 + int(KEEP(13),8) 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 + int(KEEP(14),8) 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 NBRECORDS = min(KEEP(39), NZ) ELSE NBRECORDS = min(KEEP(39), NA_ELT) 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_BYTES = KEEP( 44 ) * KEEP( 35 ) SMUMPS_LBUFR_BYTES = max( SMUMPS_LBUFR_BYTES, & 100000 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF SMUMPS_LBUFR_BYTES = SMUMPS_LBUFR_BYTES & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUFR_BYTES)/100E0) NB_BYTES = NB_BYTES + int(SMUMPS_LBUFR_BYTES,8) SMUMPS_LBUF = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 43 ) * KEEP( 35 )) ) SMUMPS_LBUF = max( SMUMPS_LBUF, 100000 ) SMUMPS_LBUF = SMUMPS_LBUF & + int( 2.0E0 * real(max(PERLU,0))* & real(SMUMPS_LBUF)/100E0) SMUMPS_LBUF = max(SMUMPS_LBUF, SMUMPS_LBUFR_BYTES) NB_BYTES = NB_BYTES + int(SMUMPS_LBUF,8) 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 + 5_8 * NSTEPS8 + 3_8 NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI 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_214 SUBROUTINE SMUMPS_757(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_757 SUBROUTINE SMUMPS_618( & 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_618 SUBROUTINE SMUMPS_710 (id, NB_INT,NB_CMPLX ) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 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%POIDS)) NB_INT=NB_INT+size(id%POIDS) 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) 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%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)) & NB_INT=NB_INT+size(id%POSINRHSCOMP) IF (associated(id%MEM_SUBTREE)) & NB_INT=NB_INT+size(id%MEM_SUBTREE) 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%COST_TRAV)) NB_INT=NB_INT+size(id%COST_TRAV) 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) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR) 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%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)) NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA)) 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_CMPLX = NB_CMPLX + NB_REAL RETURN END SUBROUTINE SMUMPS_710 SUBROUTINE SMUMPS_756(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 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 RETURN END SUBROUTINE SMUMPS_756 SUBROUTINE SMUMPS_22( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8, & 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) 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_22", & 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_730(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_632(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL SMUMPS_627(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_627(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_630( 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_724(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_94(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ)) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... alloc_cb', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF DONE = .TRUE. COMP = COMP + 1 ENDIF ENDIF IF (IWPOSCB-IWPOS+1 .LT. LREQ) THEN IF (DONE) GOTO 600 CALL SMUMPS_94(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ)) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress... alloc_cb', & 'LRLU,LRLUS=',LRLU,LRLUS GOTO 620 END IF COMP = COMP + 1 IF (IWPOSCB-IWPOS+1 .LT. LREQ) GOTO 600 ENDIF IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in SMUMPS_22",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_22",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_730(LREQCB, IW(IWPOSCB+1+XXR)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF KEEP8(67) = min(LRLUS, KEEP8(67)) #if ! defined(OLD_LOAD_MECHANISM) CALL SMUMPS_471(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #else #if defined (CHECK_COHERENCE) CALL SMUMPS_471(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #else CALL SMUMPS_471(SSARBR,.FALSE., & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLU) #endif #endif RETURN 600 IFLAG = -8 IERROR = LREQ RETURN 620 IFLAG = -9 CALL MUMPS_731(LREQCB_EFF - LRLUS, IERROR) RETURN END SUBROUTINE SMUMPS_22 SUBROUTINE SMUMPS_244(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) USE SMUMPS_LOAD 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(*) 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 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))) INTEGER INTARR(max(1,KEEP(14))) REAL DBLARR(max(1,KEEP(13))) REAL SEUIL, SEUIL_LDLT_NIV2 INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INTEGER MUMPS_275 EXTERNAL MUMPS_275 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) 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 IPTRLU = LRLU NTOTPV = 0 NMAXNPIV = 0 IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_362(N, LEAF, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL SMUMPS_506(POOL, LPOOL, LEAF) CALL SMUMPS_555(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_275( PROCNODE_STEPS(STEP(KEEP(38))), SLAVEF ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF CALL SMUMPS_251(N,IW,LIW,A,LA,IW1(NSTK),IW1(NBPROCFILS), & INFO(1),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, INFO(2), 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) POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN KEEP8(31) = POSFAC ENDIF KEEP(32) = IWPOS CALL MUMPS_735(KEEP8(31), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) 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 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), INFO(12), & 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/ & ' --- (12) NUMBER OF OFF DIAGONAL PIVOTS =',I15/ & ' --- (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) 99990 FORMAT(/ ' NUMBER OF MSGS RECVD FOR DYNAMIC LOAD =',I15) END SUBROUTINE SMUMPS_244 SUBROUTINE SMUMPS_269( MYID,KEEP,KEEP8, & 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) 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_22( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, 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_269 SUBROUTINE SMUMPS_270( 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_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, 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) 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_S(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), PTRARW(N), PTRAIW(N) REAL :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) REAL DBLARR(max(1,KEEP(13))) 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_275 EXTERNAL numroc, MUMPS_275 IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_275( 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_270" CALL MUMPS_ABORT() ENDIF ENDIF PTLUST_S(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_94( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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_S(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST_S( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_730( LREQA, IW(POSHEAD + XXR)) IW( POSHEAD + XXS )=-9999 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_731(LREQA - LRLUS, IERROR) GOTO 700 END IF CALL SMUMPS_94( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB2 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_731(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_S(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = max(POSFAC-1_8,1_8) PTRFAC (STEP(IROOT)) = max(POSFAC-1_8,1_8) 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) CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLU) POSHEAD = PTLUST_S( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_730( LREQA, IW(POSHEAD + XXR)) IW( POSHEAD + XXS ) = S_NOTFREE 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 ( KEEP( 50 ) .eq. 0 .OR. KEEP(50) .eq. 2 ) THEN OPELIW = OPELIW + ( dble(2*TOT_ROOT_SIZE) * & dble(TOT_ROOT_SIZE) * dble(TOT_ROOT_SIZE ) / dble(3) & - 0.5d0 * dble( TOT_ROOT_SIZE ) * dble( TOT_ROOT_SIZE ) & - dble( TOT_ROOT_SIZE ) / dble( 6 ) ) & / dble( root%NPROW * root%NPCOL ) ELSE OPELIW = OPELIW + ( dble(TOT_ROOT_SIZE) * & dble( TOT_ROOT_SIZE) * & dble( TOT_ROOT_SIZE + 1 ) ) & / dble( 3 * root%NPROW * root%NPCOL ) END IF 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_756(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL SMUMPS_96( 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_152(.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 ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_681(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL SMUMPS_580(IERR) ENDIF CALL SMUMPS_507( 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_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE SMUMPS_270 SUBROUTINE SMUMPS_96 &( 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_96 INTEGER FUNCTION SMUMPS_505(KEEP,KEEP8) IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) SMUMPS_505 = KEEP(28) + 1 + 3 RETURN END FUNCTION SMUMPS_505 SUBROUTINE SMUMPS_506(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_506 SUBROUTINE SMUMPS_507 & (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_170 LOGICAL MUMPS_170, 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_170(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_514(INODE,1) ENDIF ENDIF IF ( MUMPS_170(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))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)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)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_507 LOGICAL FUNCTION SMUMPS_508(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) SMUMPS_508 = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION SMUMPS_508 SUBROUTINE SMUMPS_509( 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_167, MUMPS_283, SMUMPS_508 LOGICAL MUMPS_167, MUMPS_283, SMUMPS_508 EXTERNAL MUMPS_275 INTEGER MUMPS_275 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 #if defined(POOL_EXTRACT_MNG) INTEGER POS_TO_EXTRACT #endif 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_509: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( SMUMPS_508(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in SMUMPS_509" 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_509" 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_561(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_820(FLAG_MEM) IF(FLAG_MEM)THEN CALL SMUMPS_561(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_167( PROCNODE(STEP(INODE_EFF)), SLAVEF) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL SMUMPS_513(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_283( PROCNODE(STEP(INODE_EFF)), & SLAVEF)) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL SMUMPS_513(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in SMUMPS_509", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL SMUMPS_520 & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_167( PROCNODE(STEP(INODE)), & SLAVEF) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_283( PROCNODE(STEP(INODE)), & SLAVEF)) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL SMUMPS_561(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 defined(POOL_EXTRACT_MNG) IF(KEEP(76).EQ.4)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.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 #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ELSE IF(DEPTH_FIRST_LOAD(STEP(POOL(LPOOL-2-I))).LT. & DEPTH_FIRST_LOAD(STEP(NODE_TO_EXTRACT))) & THEN POS_TO_EXTRACT=I #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ENDIF ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) INODE = NODE_TO_EXTRACT #else INODE = INODE_EFF #endif DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ENDIF IF(KEEP(76).EQ.5)THEN #if ! defined(NOT_ATM_POOL_SPECIAL) IF((INODE.GE.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 #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ELSE IF(COST_TRAV(STEP(POOL(LPOOL-2-I))).GT. & COST_TRAV(STEP(NODE_TO_EXTRACT)))THEN POS_TO_EXTRACT=I #if defined(NOT_ATM_POOL_SPECIAL) INODE_EFF = POOL(LPOOL-2-I) IF ( POOL(LPOOL-2-I) < 0 ) THEN NODE_TO_EXTRACT=-POOL(LPOOL-2-I) ELSE IF ( POOL(LPOOL-2-I) > N ) THEN NODE_TO_EXTRACT = POOL(LPOOL-2-I) - N ELSE NODE_TO_EXTRACT = POOL(LPOOL-2-I) ENDIF #else NODE_TO_EXTRACT=POOL(LPOOL-2-I) #endif ENDIF ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) INODE = NODE_TO_EXTRACT #else INODE = INODE_EFF #endif DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO #if ! defined(NOT_ATM_POOL_SPECIAL) ENDIF #endif ENDIF #endif 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_820(FLAG_MEM) IF(FLAG_MEM)THEN CALL SMUMPS_561(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_819(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_514(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_509 SUBROUTINE SMUMPS_552(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_275 EXTERNAL MUMPS_275 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_818(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL SMUMPS_818(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_554(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_819(INODE) #if ! defined(NOT_ATM_POOL_SPECIAL) ELSE ENDIF #endif END SUBROUTINE SMUMPS_552 SUBROUTINE SMUMPS_561(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_167 LOGICAL MUMPS_167 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_552(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_553(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_167(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_819(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_561 SUBROUTINE SMUMPS_574 & ( 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_574 SUBROUTINE SMUMPS_128(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, PTRAR, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & ELTNOD, NSLAVES, & XNODEL, NODEL) IMPLICIT NONE INTEGER N,NELT,LIW,IORD, SIZE_SCHUR, NSLAVES INTEGER PTRAR(N,3), NFSIZ(N), FILS(N), FRERE(N) INTEGER ELTPTR(NELT+1) INTEGER XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) INTEGER ELTVAR(ELTPTR(NELT+1)-1) INTEGER IKEEP(N,3) INTEGER LISTVAR_SCHUR(SIZE_SCHUR) INTEGER INFO(40), ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER ELTNOD(NELT) INTEGER K,I,L1,L2,IWFR,NCMPA,LLIW,IFSON,IN INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER NZ, allocok, ITEMP LOGICAL PROK, NOSUPERVAR INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER OPT_METIS_SIZE, NUMFLAG PARAMETER(OPT_METIS_SIZE = 8, NUMFLAG = 1) INTEGER OPTIONS_METIS(OPT_METIS_SIZE) INTEGER IDUM EXTERNAL MUMPS_197, SMUMPS_130, SMUMPS_131, & SMUMPS_129, SMUMPS_132, & SMUMPS_133, SMUMPS_134, & SMUMPS_199, & SMUMPS_557, SMUMPS_201 #if defined(OLDDFS) EXTERNAL SMUMPS_200 #endif ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW RETURN ENDIF MPRINT= ICNTL(3) PROK = (MPRINT.GT.0) LP = ICNTL(1) MP = ICNTL(3) 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) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) 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) IF ( IORD == 5 ) THEN IF (LIW .LT. N+N+1) THEN INFO(1)= -2002 INFO(2) = LIW RETURN ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2*N ) THEN INFO(1)= -2002 INFO(2) = LIW RETURN END IF ELSE IF ( LIW .LT. 4*N+4 ) THEN INFO(1)= -2002 INFO(2) = LIW RETURN END IF ENDIF #if defined(metis) || defined(parmetis) ENDIF #endif IDUM=0 CALL SMUMPS_258(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_129(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), IW(L1)) ELSE CALL SMUMPS_130(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), 4*N+4, IW(L1)) ENDIF LLIW = max(NZ,N) ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF IF (NOSUPERVAR) THEN CALL SMUMPS_132(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) ELSE CALL SMUMPS_131(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_162(N, LLIW, PTRAR, IWFR, PTRAR(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), PTRAR(1,3), & 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_128",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_23(N, LLIW, PTRAR, IWFR, PTRAR(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), PTRAR(1,3)) ENDIF ELSE #if defined(metis) || defined(parmetis) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS ' ENDIF CALL SMUMPS_129(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & PTRAR(1,2), IW(L1)) LLIW = max(NZ,N) ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF CALL SMUMPS_538(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW, IW(L2), PTRAR(1,2), & IW(L1), IWFR) OPTIONS_METIS(1) = 0 CALL METIS_NODEND(N, IW(L2), IW2(1), NUMFLAG, OPTIONS_METIS, & IKEEP(1,2), IKEEP(1,1) ) 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_133(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, PTRAR(1,2), IW(L1)) LLIW = NZ+N ALLOCATE( IW2(LLIW), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 INFO(2) = LLIW RETURN ENDIF CALL SMUMPS_134(N, NZ, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW, PTRAR, PTRAR(1,2), & IW(L1), IWFR) 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_128",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL SMUMPS_199(N, PTRAR, IW2, LLIW, IWFR, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP) ENDIF #if defined(OLDDFS) CALL SMUMPS_200(N, PTRAR, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) #else CALL SMUMPS_557(N, PTRAR, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, PTRAR(1,2), & INFO(6), FILS, FRERE, PTRAR(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_201(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_209( 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_510(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 IF ( huge(KEEP8(79)) / K79REF + 1_8 .GE. int(NSLAVES,8) ) THEN KEEP8(79)=huge(KEEP8(79)) ELSE KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF ENDIF IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN CALL SMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0) .AND. (NSLAVES.GE.ICNTL(13))) IF (SPLITROOT) THEN CALL SMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) RETURN 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 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) 90 CONTINUE DEALLOCATE(IW) 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_128 SUBROUTINE SMUMPS_258( 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_258 ***') END SUBROUTINE SMUMPS_258 SUBROUTINE SMUMPS_129(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD, 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 DO I = 1,N NZ = NZ + LEN(I) ENDDO RETURN END SUBROUTINE SMUMPS_129 SUBROUTINE SMUMPS_538(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER LEN(N) INTEGER IPE(N+1) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1 DO I = 1,N IWFR = IWFR + LEN(I) 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_538 SUBROUTINE SMUMPS_132(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER LEN(N) INTEGER IPE(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 DO I = 1,N IWFR = IWFR + LEN(I) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0 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 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_132 SUBROUTINE SMUMPS_133(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD 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 DO I = 1,N NZ = NZ + LEN(I) ENDDO RETURN END SUBROUTINE SMUMPS_133 SUBROUTINE SMUMPS_134(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER IPE(N), LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0 DO I = 1,N IWFR = IWFR + LEN(I) + 1 IPE(I) = IWFR ENDDO IWFR = IWFR + 1 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 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = IPE(I) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0 ENDDO RETURN END SUBROUTINE SMUMPS_134 SUBROUTINE SMUMPS_25( 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 PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 INTEGER ELT, I, K, IPTRI, IPTRR, NVAR INTEGER TYPE_PARALL, ITYPE, IRANK TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_330( PROCNODE(abs(STEP(I))), SLAVEF ) IRANK = MUMPS_275( 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 IPTRI = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI IPTRI = IPTRI + NVAR ENDDO PTRAIW( NELT+1 ) = IPTRI KEEP( 14 ) = IPTRI - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + NVAR*NVAR ENDDO PTRARW( NELT+1 ) = IPTRR ELSE IPTRR = 1 DO ELT = 1,NELT NVAR = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + (NVAR*(NVAR+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR = 1 DO ELT = 1,NELT NVAR = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + NVAR*NVAR ENDDO PTRARW( NELT+1 ) = IPTRR ELSE IPTRR = 1 DO ELT = 1,NELT NVAR = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR IPTRR = IPTRR + (NVAR*(NVAR+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR ENDIF ENDIF KEEP( 13 ) = IPTRR - 1 RETURN END SUBROUTINE SMUMPS_25 SUBROUTINE SMUMPS_120( N, NELT, ELTPROC, SLAVEF, PROCNODE ) IMPLICIT NONE INTEGER N, NELT, SLAVEF INTEGER PROCNODE( N ), ELTPROC( NELT ) INTEGER ELT, I, ITYPE, MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_330(PROCNODE(I),SLAVEF) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_275(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_120 SUBROUTINE SMUMPS_153(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER FRERE(N), FILS(N), NA(N), NE(N) INTEGER FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER XNODEL(N+1), NODEL(NELNOD) INTEGER TNSTK( N ), IPOOL( N ) INTEGER I, K, IFATH INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN 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 file SMUMPS_153 ' 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 RETURN END SUBROUTINE SMUMPS_153 SUBROUTINE SMUMPS_130(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW 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_315 LP = 6 CALL SMUMPS_315(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_315. 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 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 + LEN(I) ENDDO RETURN END SUBROUTINE SMUMPS_130 SUBROUTINE SMUMPS_131(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NZ,NELT,NELNOD,LW,IWFR INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER IPE(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + LEN(I) IPE(I) = IWFR ELSE IPE(I) = 0 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_131 SUBROUTINE SMUMPS_315(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_316 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_316(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_315: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I8) END SUBROUTINE SMUMPS_315 SUBROUTINE SMUMPS_316( 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_316 SUBROUTINE SMUMPS_36( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & & NSTK_S,NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER NELT,N,LIW,NSTEPS INTEGER(8) LA, LRLU, LRLUS, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER IFLAG,IERROR,INODE,MAXFRW, & IWPOS, IWPOSCB, COMP INTEGER IDUMMY(1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(NELT+1), PTRAIW(NELT+1), ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(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 A(LA) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER INTARR(max(1,KEEP(14))) REAL DBLARR(max(1,KEEP(13))) 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 INCLUDE 'mumps_headers.h' LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER MUMPS_330 EXTERNAL MUMPS_330 INTEGER LP, HS, HF INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER(8) NFRONT8 INTEGER(8) LAELL8, APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) LSTK8, SIZFR8 #if defined(ALLOW_NON_INIT) INTEGER(8) :: JJ8 #endif INTEGER NBPANELS_L, NBPANELS_U, LREQ_OOC INTEGER SIZFI, NCB INTEGER JJ,J1,J2 INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM,JJ1,J3, & IORG, IBROT INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER AINPUT, & AII, 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, SIZE_ELTI INTEGER II, I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER NCBSON LOGICAL SAME_PROC INTRINSIC real REAL ZERO PARAMETER( ZERO = 0.0E0 ) LOGICAL MUMPS_167, SSARBR EXTERNAL MUMPS_167 DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_170 LOGICAL MUMPS_170 NFS4FATHER = -1 ETATASS = 0 COMPRESSCB=.FALSE. IN = INODE NBPROCFILS(STEP(IN)) = 0 LEVEL = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (LEVEL.NE.1) THEN write(6,*) 'Error1 in mpi51f_niv1 ' 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 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG LREQ_OOC = 0 IF (KEEP(201).EQ.1) THEN CALL SMUMPS_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' 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. IF (KEEP(50).EQ.0) THEN CALL MUMPS_124( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, NFRONT, NFRONT_EFF, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG ) ELSE CALL MUMPS_125( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IF (IFLAG.LT.0) GOTO 300 END IF IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_170(PROCNODE_STEPS(STEP(INODE)), & SLAVEF))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_511(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL SMUMPS_190(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 Write(*,*) ' ERROR 1 during ass_niv1_ELT' GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL SMUMPS_691(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_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv1.F' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 END IF END IF END IF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) CALL SMUMPS_471(SSARBR,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, & LRLU) #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, int(NFRONT -1,8) A(APOS:APOS+JJ8) = ZERO APOS = APOS + NFRONT8 END DO END IF #endif NASS = NASS1 PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST_S(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 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)) LSTK = IW(ISTCHK+KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = IW(ISTCHK + 1+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.LE.IWPOS) IF ( SAME_PROC ) THEN COMPRESSCB = & ( IW(PTRIST(STEP(ISON))+XXS) .EQ. S_CB1COMP ) ELSE COMPRESSCB = ( IW(ISTCHK + XXS) .EQ. S_CB1COMP ) ENDIF LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = IW( ISTCHK + 2+KEEP(IXSZ)) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS J1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1) THEN J2 = J1 + 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 J2 = J1 + NELIM - 1 ENDIF OPASSW = OPASSW + dble(SIZFR8) IACHK = PAMASTER(STEP(ISON)) IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (J2.GE.J1) THEN DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * NFRONT8 DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + A(IACHK + int(JJ1 - 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(J2 - J1 + 1,8) ENDIF CALL SMUMPS_178(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), J2 - J1 + 1, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) END DO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) END DO IF (NELIM .NE. 0) THEN J3 = J3 - 1 DO JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) END DO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP( ISON )) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL SMUMPS_152(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_49( & 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_210( 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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP,KEEP8, 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 & ) IF ( IFLAG .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_71( 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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = INTARR(II) IF (KEEP(50).EQ.0) THEN AINPUT = AII + II - J1 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ=J1,J2 APOS2 = ICT12 + int(INTARR(JJ) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ=II,J2 J = INTARR(JJ) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII) AII = AII + 1 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 JJ=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ELSE DO JJ=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+JJ-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-1) * KEEP(254) + IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF GOTO 500 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_36' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, WORKSPACE TOO SMALL DURING SMUMPS_36' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8-LRLUS, IERROR) GOTO 500 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING SMUMPS_36' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = 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 DURING SMUMPS_36' ENDIF IFLAG = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING SMUMPS_36' ENDIF IFLAG = -13 IERROR = NUMSTK 490 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_36 SUBROUTINE SMUMPS_37( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, IFLAG, & IERROR, ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, & MEM_DISTRIB) USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER NELT, N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) INTEGER(8) LRLU, IPTRLU, LRLUS, POSFAC, LA INTEGER(8) LAELL8 INTEGER JJ INTEGER IFLAG,IERROR,INODE,MAXFRW, & LPOOL, LEAF, & IWPOS, & IWPOSCB, COMP, SLAVEF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & PTRARW(NELT+1), PTRAIW(NELT+1), ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), STEP(N), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PAMASTER(KEEP(28)), & PTRAST(KEEP(28)) 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) DOUBLE PRECISION OPASSW, OPELIW INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER INTARR(max(1,KEEP(14))) REAL DBLARR(max(1,KEEP(13))) INTEGER MYID, COMM INTEGER LBUFR, LBUFR_BYTES INTEGER NBPROCFILS(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF, HF_OLD, NSLAVES_OLD,NCBSON INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL LOGICAL COMPRESSCB INTEGER(8) :: LCB INTEGER NFS4FATHER INTEGER NFRONT,NFRONT_EFF,ISTCHK,LSTK,LREQ INTEGER LREQ_OOC, NBPANELS_L, NBPANELS_U INTEGER NCB INTEGER J1,J2 INTEGER(8) NFRONT8, LAPOS2, POSELT, POSEL1, LDAFS8, & JJ2, IACHK, ICT12, ICT21 #if defined(ALLOW_NON_INIT) INTEGER(8) :: JJ8 #endif INTEGER(8) APOS, APOS2 INTEGER NELIM,LDAFS,JJ1,NPIVS,NCOLS,NROWS, & IORG INTEGER LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER AINPUT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, ISLAVE, PDEST INTEGER ELTI, SIZE_ELTI INTEGER II, ELBEG, NUMELT, I, J, AII LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX logical :: force_cand INTEGER(8) APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NUMORG_SPLIT, TYPESPLIT, & NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER IZERO INTEGER IDUMMY(1) INTEGER PDEST1(1) INTEGER ETATASS PARAMETER( IZERO = 0 ) INTEGER MUMPS_275, MUMPS_330, MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, MUMPS_810 INTRINSIC real REAL ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = 0.0E0 ) 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) END DO 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_330(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) END IF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO 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 IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) SIZE_TMP_SLAVES_LIST = CAND( SLAVEF+1, INIV2 ) ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_810 (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 265 ENDIF CALL SMUMPS_791 ( & 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_472( 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_790 ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) TMP_SLAVES_LIST (1:SIZE_TMP_SLAVES_LIST) & = CAND (1:SIZE_TMP_SLAVES_LIST, INIV2) CALL SMUMPS_792 ( & INODE, TYPESPLIT, IFSON, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, NBSPLIT, NCB, & 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_472( 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_684(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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. IF (KEEP(50).EQ.0) THEN CALL MUMPS_124( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, NFRONT,NFRONT_EFF, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) ELSE CALL MUMPS_125( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, & IFSON, STEP, PIMASTER, PTRAIW, NELT, IW, LIW, & INTARR, KEEP(14), ITLOC, RHS_MUMPS, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, NBPROCFILS, IFLAG, & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG) IF (IFLAG.LT.0) GOTO 250 ENDIF IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN 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 WRITE(6,*) ' Internal error 2 in fac_ass_elt due', & ' to plitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF CALL MUMPS_ABORT() ELSE CALL SMUMPS_472( 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 JJ=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+JJ)=IW(IOLDPS+HF_OLD+JJ) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO JJ=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+JJ) = IW(IOLDPS+HF_OLD+JJ) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE Write(*,*) ' ERROR 2 during ass_niv2' GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL SMUMPS_691(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST_S(STEP(INODE)) = IOLDPS 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+KEEP(IXSZ)) = NFRONT 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_461(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_533(SLAVEF,CAND(SLAVEF+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_533(SLAVEF,SLAVEF-1, & 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) THEN IF(KEEP(50) .EQ. 2) LAELL8 = LAELL8+int(NASS1,8) ENDIF LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF IF (LRLU .LT. LAELL8) THEN IF (LRLUS .LT. LAELL8) THEN GOTO 280 ELSE CALL SMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ass..mpi51f_niv2' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 280 ENDIF ENDIF ENDIF LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_730(LAELL8,IW(IOLDPS+XXR)) IW(IOLDPS+XXS) =-9999 IW(IOLDPS+XXS+1:IOLDPS+KEEP(IXSZ)-1)=-99999 CALL SMUMPS_471(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, &LRLU) POSEL1 = POSELT - LDAFS8 #if ! defined(ALLOW_NON_INIT) 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 A(POSELT:LAPOS2) = ZERO ELSE APOS = POSELT DO JJ8 = 0_8, LDAFS8 - 1_8 A(APOS:APOS+JJ8) = ZERO APOS = APOS + LDAFS8 END DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN A(APOS:APOS+LDAFS8-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.LE.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) J1 = ISTCHK + HS + NROWS + NPIVS J2 = J1 + NELIM - 1 IACHK = PAMASTER(STEP(ISON)) IF (KEEP(50).eq.0) THEN DO 170 JJ = J1, J2 APOS = POSEL1 + int(IW(JJ),8) * LDAFS8 DO 160 JJ1 = 1, LSTK JJ2 = APOS + int(IW(J1 + JJ1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + A(IACHK + int(JJ1,8) - 1_8) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE 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 CALL SMUMPS_178(A, LA, & POSELT, LDAFS, NASS1, & IACHK, LDA_SON, LCB, & IW( J1 ), NELIM, NELIM, ETATASS, & COMPRESSCB, & .FALSE. & ) 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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = INTARR(II) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT = AII + II - J1 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ=J1,J2 APOS2 = ICT12 + int(INTARR(JJ) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI 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) THEN IF (KEEP(50).EQ.2) THEN AINPUT=AII DO JJ=II,J2 J=INTARR(JJ) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))= & max(real(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT))) ENDIF AINPUT=AINPUT+1 ENDDO ELSE AII = AII + J2 - II + 1 CYCLE ENDIF ELSE AII = AII + J2 - II + 1 CYCLE ENDIF ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ=II,J2 J = INTARR(JJ) 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(AII) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII))) ENDIF AII = AII + 1 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 JJ = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+JJ-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (JJ-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) DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & 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_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & IW(PDEST), NFRONT, COMM, IERR) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL SMUMPS_68( INODE, & NBPROCFILS(STEP(INODE)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST_S(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & IW(PDEST), NFRONT, COMM, IERR) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.) IF ( IFLAG .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST_S(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF END DO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 END DO 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.LE.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_275(PROCNODE_STEPS(STEP(ISON)), & SLAVEF) IF (PDEST1(1).EQ.MYID) THEN CALL SMUMPS_211( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8, 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 ) IF ( IFLAG .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL SMUMPS_71( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST_S(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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_49( & 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_210( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST_S(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_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, NBPROCFILS, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8, 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 & ) IF ( IFLAG .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_71( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST_S(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_329( 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, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .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)) END DO GOTO 500 250 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION during assembly' ENDIF IFLAG = -13 IERROR = NUMSTK + 1 GOTO 490 265 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DYNAMIC ALLOCATION during assembly' ENDIF IFLAG = -13 IERROR = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE IFLAG = -8 IERROR = LREQ IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_37' ENDIF GOTO 490 280 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) & ' FAILURE, WORKSPACE TOO SMALL DURING SMUMPS_37' ENDIF IFLAG = -9 CALL MUMPS_731(LAELL8 - LRLUS, IERROR) 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_37' ENDIF IFLAG = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = 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_37' ENDIF IFLAG = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SENDBUFFER TOO SMALL (2) DURING SMUMPS_37' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECVBUFFER TOO SMALL (2) DURING SMUMPS_37' ENDIF IFLAG = -17 LREQ = NBLIG + NBCOL + 4+KEEP(IXSZ) IERROR = LREQ * KEEP( 34 ) GOTO 490 490 CALL SMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_37 SUBROUTINE SMUMPS_123( & 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), PTRARW(NELT+1), & PTRAIW(NELT+1) REAL :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) REAL A(LA), & DBLARR(max(1,KEEP(13))) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSELT, APOS2, ICT12, APOS INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,I,J,JPOS,NASS,JJ, & IN,AINPUT,J1,J2,IJROW,ILOC, & ELBEG, NUMELT, ELTI, SIZE_ELTI, IPOS, & IPOS1, IPOS2, AII, II, IELL INTEGER :: K1RHS, K2RHS, JFirstRHS 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 A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = & ZERO 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) J1= PTRAIW(ELTI) J2= PTRAIW(ELTI+1)-1 AII = PTRARW(ELTI) SIZE_ELTI = J2 - J1 + 1 DO II=J1,J2 I = ITLOC(INTARR(II)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT = AII + II - J1 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ = J1, J2 JPOS = ITLOC(INTARR(JJ)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT) AINPUT = AINPUT + SIZE_ELTI END DO ELSE IF ( I .EQ. 0 ) THEN AII = AII + J2 - II + 1 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 JJ=II,J2 AII = AII + 1 J = ITLOC(INTARR(JJ)) 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(AII-1) 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(AII-1) 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 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_123 SUBROUTINE SMUMPS_126( & N, NELT, NA_ELT, & COMM, MYID, SLAVEF, & IELPTR_LOC, RELPTR_LOC, & ELTVAR_LOC, ELTVAL_LOC, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NELT, NA_ELT 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 IELPTR_LOC( NELT + 1 ), RELPTR_LOC( NELT + 1 ) INTEGER ELTVAR_LOC( max(1,KEEP(14)) ) REAL ELTVAL_LOC( max(1,KEEP(13)) ) REAL A( LA ) TYPE(SMUMPS_STRUC) :: id TYPE(SMUMPS_ROOT_STRUC) :: root INTEGER numroc EXTERNAL numroc INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR_MPI INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER RECV_IELTPTR, RECV_RELTPTR INTEGER IELTPTR, RELTPTR, INODE 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, K, NB_REC, IREC INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER IVALPTR 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, DIMENSION( : ), ALLOCATABLE :: ELROOTPOS 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 ) 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 = min(KEEP(39),NA_ELT) 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( ELROOTPOS( 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_276( 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_IELTPTR = 1 RECV_RELTPTR = 1 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR = 1 RELPTR_LOC(1) = 1 DO IEL = 1, NELT IELTPTR = id%ELTPTR( IEL ) SIZEI = id%ELTPTR( IEL + 1 ) - IELTPTR 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 ELROOTPOS( NBELROOT ) = RELTPTR GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL SMUMPS_288( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR ), id%A_ELT( RELTPTR ), & 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_IELTPTR: RECV_IELTPTR + SIZEI - 1 ) & = id%ELTVAR( IELTPTR: IELTPTR + SIZEI - 1 ) RECV_IELTPTR = RECV_IELTPTR + SIZEI IF ( KEEP(52) .ne. 0 ) THEN ELTVAL_LOC( RECV_RELTPTR: RECV_RELTPTR + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR = RECV_RELTPTR + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL SMUMPS_127( & id%ELTVAR(IELTPTR), & id%A_ELT (RELTPTR), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL SMUMPS_127( & id%ELTVAR(IELTPTR), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR = RELTPTR + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC( IEL + 1 ) = RELTPTR ELSE RELPTR_LOC( IEL + 1 ) = RECV_RELTPTR ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP(13) = RELTPTR - 1 ELSE KEEP(13) = RECV_RELTPTR - 1 ENDIF IF ( RELTPTR - 1 .ne. id%NA_ELT ) THEN WRITE(*,*) ' ** ERROR ELT DIST: RELPTR - 1 / id%NA_ELT=', & RELTPTR - 1,id%NA_ELT CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR = 1 RELTPTR = 1 SIZEI = 1 SIZER = 1 CALL SMUMPS_127( & id%ELTVAR(IELTPTR), & id%A_ELT (RELTPTR), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR .eq. IELPTR_LOC( NELT+1 ) & .and. RECV_RELTPTR .eq. RELPTR_LOC( 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_IELTPTR ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR = RECV_IELTPTR + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_REAL, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR ), MSGLEN, & MPI_REAL, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR = RECV_RELTPTR + MSGLEN END SELECT FINI = ( RECV_IELTPTR .eq. IELPTR_LOC( NELT+1 ) & .and. RECV_RELTPTR .eq. RELPTR_LOC( 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_276( 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 IVALPTR = ELROOTPOS( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K = 1 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( IVALPTR + K ) ELSE VAL = id%A_ELT( IVALPTR + K ) * & 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_34( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) END IF K = K + 1 END DO END DO END DO CALL SMUMPS_18( & 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(ELROOTPOS) IF (KEEP(46) .eq. 0 ) THEN DEALLOCATE(RG2LALLOC) ENDIF ENDIF DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE SMUMPS_126 SUBROUTINE SMUMPS_127( & 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_127 SUBROUTINE SMUMPS_213( 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_213 SUBROUTINE SMUMPS_288( 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_288 SUBROUTINE SMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, ICNTL, CNTL, & NZ, IRN, IRNhere, JCN, JCNhere, A, Ahere, & NZ_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 ICNTL(40), INFO(40), INFOG(40) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN REAL CNTL(15), RINFO(40), RINFOG(40) 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(in) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(in) :: 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 SMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (SMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_AFFECT_MAPPING, & MUMPS_AFFECT_PIVNUL_LIST, & MUMPS_AFFECT_SYM_PERM, & MUMPS_AFFECT_UNS_PERM 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%NZ_loc = NZ_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%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) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NZ) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NZ) IF ( Ahere /= 0 ) mumps_par%A => A(1:NZ) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NZ_loc) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NZ_loc) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NZ_loc) 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) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NZ = mumps_par%NZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_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_AFFECT_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_AFFECT_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_AFFECT_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_AFFECT_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF 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-4.10.0.dfsg/src/zmumps_part5.F0000644000175300017530000102467411562233070017462 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE ZMUMPS_26(id) USE ZMUMPS_LOAD USE MUMPS_STATIC_MAPPING USE ZMUMPS_STRUC_DEF USE TOOLS_COMMON USE ZMUMPS_PARALLEL_ANALYSIS IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER LIW, IKEEP, FILS, FRERE, PTRAR, NFSIZ INTEGER NE, NA INTEGER I, allocok INTEGER MAXIS1_CHECK 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 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 INTEGER(8) K13TMP8, K14TMP8 DOUBLE PRECISION PEAK INTEGER, ALLOCATABLE, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR 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_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 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 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 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 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (PROK) WRITE( MP, 220 ) IF (PROKG.AND.(MPG .NE. MP)) WRITE( MPG, 220 ) id%VERSION_NUMBER 220 FORMAT( /' ZMUMPS ',A ) 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 ) CALL ZMUMPS_647(id) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ) ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN CALL MPI_ALLREDUCE( id%NZ_loc, id%NZ, 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR ) ELSE CALL MPI_BCAST( id%NZ, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) END IF ELSE CALL MPI_BCAST( id%NA_ELT, 1, MPI_INTEGER, 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_427( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO) CALL ZMUMPS_658(id) IF (KEEP(244) .EQ. 1) THEN IF ( KEEP(54) .eq. 3 ) THEN CALL ZMUMPS_664(id) END IF IF ( id%MYID .eq. MASTER ) THEN 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 IF (.not.associated(id%A)) THEN IF (KEEP(23).GT.2) KEEP(23) = 1 ENDIF CALL ZMUMPS_203(id%N, id%NZ, KEEP(23), id%IS1(1), id, & ICNTL(1), INFO(1)) IF (INFO(1) .LT. 0) THEN KEEP(23) = 0 GOTO 10 END IF END IF IF (KEEP(55) .EQ. 0) THEN IF ( KEEP(256) .EQ. 1 ) THEN LIW = 2 * id%NZ + 3 * id%N + 2 ELSE LIW = 2 * id%NZ + 3 * id%N + 2 ENDIF IF (LIW.LT.3*id%N) LIW = 3*id%N ELSE #if defined(metis) || defined(parmetis) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN LIW = id%N + id%N + 1 ELSE LIW = id%N + id%N + id%N+3 + id%N+1 ENDIF ENDIF IF (LIW.LT.3*id%N) LIW = 3*id%N 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 PTRAR = FRERE + id%N IF (KEEP(55) .EQ. 0) THEN NFSIZ = PTRAR + 4 * id%N MAXIS1_CHECK = NFSIZ + id%N - 1 ELSE NFSIZ = PTRAR + 2 * (NELT + 1) MAXIS1_CHECK = NFSIZ + id%N -1 ENDIF IF ( id%MAXIS1 .LT. MAXIS1_CHECK ) THEN IF (LP.GE.0) THEN WRITE(LP,*) '***********************************' WRITE(LP,*) 'MAXIS1 and MAXIS1_CHECK are different !!' WRITE(LP,*) 'MAXIS1, MAXIS1_CHECK=',id%MAXIS1, & MAXIS1_CHECK WRITE(LP,*) 'This might cause problems ...' WRITE(LP,*) '***********************************' ENDIF END IF IF ( KEEP(256) .EQ. 1 ) THEN DO I = 1, id%N id%IS1( IKEEP + I - 1 ) = id%PERM_IN( I ) END DO END IF INFOG(1) = 0 INFOG(2) = 0 INFOG(8) = -1 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 IF (KEEP(55) .EQ. 0) THEN CALL ZMUMPS_195(id%N, id%NZ, id%IRN(1), id%JCN(1), & LIW, id%IS1(IKEEP), & id%IS1(PTRAR), 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 KEEP(23) = -KEEP(23) IF (.NOT. associated(id%A)) KEEP(23) = 1 GOTO 1234 ENDIF INFOG(7) = KEEP(256) ELSE allocate( IWtemp ( 3*id%N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*id%N IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IWtemp' END IF GOTO 10 ENDIF allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL ZMUMPS_128(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW, & id%IS1(IKEEP), & IWtemp(1), 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%ELTPROC(1), id%NSLAVES, & XNODEL(1), NODEL(1)) DEALLOCATE(IWtemp) INFOG(7)=KEEP(256) ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN deallocate( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) ENDIF INFO(1)=INFOG(1) INFO(2)=INFOG(2) KEEP(28) = INFOG(6) IF ( INFO(1) .LT. 0 ) THEN GO TO 10 ENDIF ENDIF ELSE IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N PTRAR = FRERE + id%N NFSIZ = PTRAR + 4 * id%N IF(id%MYID .EQ. MASTER) THEN WORK1PTR => id%IS1(IKEEP : IKEEP + 3*id%N-1) WORK2PTR => id%IS1(PTRAR : PTRAR + 4*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) ELSE ALLOCATE(WORK1PTR(3*id%N)) ALLOCATE(WORK2PTR(4*id%N)) END IF CALL ZMUMPS_715(id, & WORK1PTR, & WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR) IF(id%MYID .EQ. 0) THEN NULLIFY(WORK1PTR, WORK2PTR, NFSIZPTR) NULLIFY(FILSPTR, FREREPTR) ELSE DEALLOCATE(WORK1PTR, WORK2PTR) END IF KEEP(28) = INFOG(6) END IF 10 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN IF(id%MYID .EQ. MASTER) THEN CALL MUMPS_633(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL ZMUMPS_348(id%N, id%IS1(FILS), id%IS1(FRERE), & id%IS1(IKEEP+2*id%N), id%IS1(IKEEP+id%N)) IF (id%NSLAVES .EQ. 1) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN id%KEEP(20)=0 id%KEEP(38)=0 ENDIF id%KEEP(56)=0 id%PROCNODE = 0 IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN CALL ZMUMPS_564(id%KEEP(38), id%PROCNODE(1), & 1+2*id%NSLAVES, id%IS1(FILS),id%N) ENDIF ELSE PEAK = dble(id%INFOG(5))*dble(id%INFOG(5)) + & dble(id%KEEP(2))*dble(id%KEEP(2)) SSARBR => id%IS1(IKEEP:IKEEP+id%N-1) CALL ZMUMPS_537(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 in MUMPS_369' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL ZMUMPS_348(id%N, id%IS1(FILS), & id%IS1(FRERE), id%IS1(IKEEP+2*id%N), & id%IS1(IKEEP+id%N)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ) ELSE LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_733(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_733(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_733(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN IF(id%MYID .EQ. MASTER) THEN CALL ZMUMPS_153( & 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 id%PTRAR(id%NELT+I+1)=id%ELTPTR(I) ENDDO deallocate(XNODEL) deallocate(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER, & 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 IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN CALL ZMUMPS_120(id%N, NELT, id%ELTPROC(1),id%NSLAVES, & id%PROCNODE(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LP .GT. 0 ) 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_330(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_26", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_393 & (PAR2_NODES,id%CANDIDATES,IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF CALL MUMPS_494() 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF 12 CONTINUE KEEP(84) = ICNTL(27) END IF CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MUMPS_749( id%KEEP8(21), MASTER, & id%MYID, id%COMM, IERR) CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MUMPS_733(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_733(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_733(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_733(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_733(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_733(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_733(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_733(id%SYM_PERM, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 IF (KEEP(55) .EQ. 0) THEN LPTRAR = id%N+id%N CALL MUMPS_733(id%PTRAR, LPTRAR, id%INFO, LP, FORCE=.TRUE., & STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF ( associated( id%UNS_PERM ) ) deallocate(id%UNS_PERM) IF ( id%MYID == MASTER .AND. id%KEEP(23) .NE. 0 ) THEN allocate(id%UNS_PERM(id%N),stat=allocok) IF ( allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = id%N IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'id%UNS_PERM' END IF GOTO 94 ENDIF DO I=1,id%N id%UNS_PERM(I) = id%IS1(I) END DO ENDIF 94 CONTINUE CALL MUMPS_276( 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 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_733(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 id%NA(1) = NBLEAF id%NA(2) = NBROOT 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF IF ( id%MYID .EQ. MASTER ) THEN ISTEP = 0 DO I = 1, id%N IF ( id%IS1(FRERE+I-1) .ne. id%N + 1 ) THEN 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 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_26' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in ZMUMPS_26' CALL MUMPS_ABORT() ENDIF 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 DO I = 1, id%N IF ( id%STEP(I) .LE. 0) CYCLE IF (id%IS1(FRERE+I-1) .eq. 0) THEN id%DAD_STEPS(id%STEP(I)) = 0 ENDIF IFS = id%IS1(FILS+I-1) DO WHILE ( IFS .GT. 0 ) IFS= id%IS1(FILS + IFS -1) END DO IFS = -IFS DO WHILE (IFS.GT.0) id%DAD_STEPS(id%STEP(IFS)) = I IFS = id%IS1(FRERE+IFS-1) ENDDO END DO deallocate(id%PROCNODE) NULLIFY(id%PROCNODE) deallocate(id%IS1) NULLIFY(id%IS1) CALL ZMUMPS_363(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(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 SIZE_TEMP_MEM = id%NBSA ELSE 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 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 ( LP .GT. 0 ) 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_364(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 CALL ZMUMPS_181(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) ) ENDIF 80 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN 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(55) .EQ. 0) THEN CALL ZMUMPS_746(id, id%PTRAR(1)) IF(id%MYID .EQ. MASTER) THEN IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN DEALLOCATE( id%IRN ) DEALLOCATE( id%JCN ) END IF END IF ENDIF 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_276( 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 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 ( LP .GT. 0 ) 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 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(id%STEP(INN)) = INIV2 END DO CALL ZMUMPS_649( id%NSLAVES, & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF #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 ( LP .GT. 0 ) 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_275( & id%PROCNODE_STEPS(id%STEP(PAR2_NODES(INIV2))), & id%NSLAVES) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO #endif 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 allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LP .GT. 0 ) 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 IF (NB_NIV2.GT.0) deallocate (PAR2_NODES) 321 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN 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 PTRAR = FRERE + id%N IF (KEEP(55) .EQ. 0) THEN IF ( id%MYID.EQ.MASTER ) THEN NFSIZ = PTRAR + 4 * id%N ELSE NFSIZ = PTRAR + 2 * id%N ENDIF ELSE NFSIZ = PTRAR + 2 * (NELT + 1) END IF IF ( KEEP(38) .NE. 0 ) THEN CALL ZMUMPS_164( 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 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 ( LP > 0 .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 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF ( I_AM_SLAVE ) THEN IF (KEEP(55) .EQ. 0) THEN CALL ZMUMPS_24( 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_25( 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 IF ( I_AM_SLAVE ) THEN 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 id%SCHUR_MLOC=LOCAL_M id%SCHUR_NLOC=LOCAL_N 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_246( id%MYID_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), & KEEP8(14), & 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), & id%I_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%MAX_SURF_MASTER = KEEP8(15) KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 2* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) INFO( 19 ) = KEEP(225) + 2* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /100_8 +1_8) CALL MUMPS_736 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) 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 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 ) KEEP(44) = max(KEEP(44), MIN_BUF_SIZE) KEEP(43) = max(KEEP(43), MIN_BUF_SIZE) IF ( MP .GT. 0 ) THEN WRITE(MP,'(A,I10) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I10) ') & ' INFO(3), est. complex space to store factors:', & KEEP8(11) WRITE(MP,'(A,I10) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I10) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I10) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I10) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I10) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF ELSE 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 CALL MUMPS_736( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_736( 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_646( KEEP8(11), KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735( KEEP8(111), INFOG(3) ) CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_DOUBLE_PRECISION, MPI_SUM, & id%COMM, IERR) CALL MUMPS_735( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_735( KEEP8(13), INFO(8) ) CALL MUMPS_735( KEEP8(17), INFO(20) ) CALL MUMPS_735( KEEP8(9), INFO(24) ) INFOG( 4 ) = KEEP( 126 ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_735( KEEP8(109), INFOG(20) ) CALL ZMUMPS_100(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1)) OOC_STAT = KEEP(201) IF (KEEP(201) .NE. -1) OOC_STAT=0 PERLU_ON = .FALSE. CALL ZMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(2) = TOTAL_BYTES PERLU_ON = .TRUE. CALL ZMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' Estimated space in MBYTES for IC factorization :', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES CALL MUMPS_243( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of proc needing largest memory in IC facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Estimated corresponding MBYTES for IC facto :', & id%INFOG(16) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,(id%INFOG(17)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,id%INFOG(17)/id%NSLAVES END IF WRITE(MPG,'(A,I10) ') & ' ** TOTAL space in MBYTES for IC factorization :' & ,id%INFOG(17) END IF 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. CALL ZMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(3) = TOTAL_BYTES PERLU_ON = .TRUE. CALL ZMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) id%INFO(17) = TOTAL_MBYTES CALL MUMPS_243( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of proc needing largest memory for OOC facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Estimated corresponding MBYTES for OOC facto :', & id%INFOG(26) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,(id%INFOG(27)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,id%INFOG(27)/id%NSLAVES END IF WRITE(MPG,'(A,I10) ') & ' ** TOTAL space in MBYTES for OOC factorization :' & ,id%INFOG(27) END IF IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) & deallocate( id%MAPPING) allocate( id%MAPPING(id%NZ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NZ IF ( LP .GT. 0 ) 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF CALL ZMUMPS_83( & id%N, id%MAPPING(1), & id%NZ, 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 150 FORMAT( & /' ** FAILURE DURING ZMUMPS_26, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE ZMUMPS_26 SUBROUTINE ZMUMPS_537(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_369(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & ) RETURN END SUBROUTINE ZMUMPS_537 SUBROUTINE ZMUMPS_564(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_564 SUBROUTINE ZMUMPS_647(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (id%MYID.eq.MASTER) THEN id%KEEP(256) = id%ICNTL(7) id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 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 id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN 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 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 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 WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' id%KEEP(60)=0 END IF 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 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 IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF id%KEEP(244) = id%ICNTL(28) id%KEEP(245) = id%ICNTL(29) #if ! defined(parmetis) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP,'("ParMETIS not available.")') WRITE(LP,'("Aborting.")') RETURN END IF END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP,'("PT-SCOTCH not available.")') WRITE(LP,'("Aborting.")') RETURN END IF END IF #endif IF((id%KEEP(244) .GT. 2) .OR. & (id%KEEP(244) .LT. 0)) id%KEEP(244)=0 IF(id%KEEP(244) .EQ. 0) THEN id%KEEP(244) = 1 ELSE IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') RETURN END IF 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 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) = 0 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 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 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 IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF 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 id%INFO(1) = -22 id%INFO(2) = 8 RETURN IF (MPG.GT.0) 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 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 id%KEEP(23) = id%ICNTL(6) IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 7 IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not compatible with LLT factorization' END IF ENDIF id%KEEP(95) = 1 END IF IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (MPG.GT.0) 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 (MPG.GT.0) 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. MPG.GT.0) 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 (MPG.GT.0) 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 IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed for element matrix' END IF id%KEEP(23) = 0 ENDIF IF (MPG.GT.0 .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 IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') RETURN END IF END IF IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF IF (id%ICNTL(39).NE.1 .and. id%ICNTL(39).NE.2) THEN id%KEEP(106)=1 ELSE id%KEEP(106)=id%ICNTL(39) ENDIF IF(id%KEEP(50) .EQ. 2) THEN IF( .NOT. associated(id%A) ) THEN 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 IF (PROK) WRITE(MP,*) & 'WARNING: ZMUMPS_203 constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) 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 IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE 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 id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF id%KEEP(53)=0 IF(id%KEEP(86).EQ.1)THEN 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 END IF RETURN END SUBROUTINE ZMUMPS_647 SUBROUTINE ZMUMPS_664(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE(ZMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER :: MASTER, IERR, INDX, NRECV INTEGER :: STATUS( MPI_STATUS_SIZE ) INTEGER :: LP, MP, MPG, I LOGICAL :: PROK, PROKG PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN id%NZ_loc = 0 END IF IF ( id%MYID .eq. MASTER ) THEN allocate( REQPTR( id%NPROCS, 3 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 3 * id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'REQPTR' END IF GOTO 13 END IF allocate( id%IRN( id%NZ ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NZ IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IRN' END IF GOTO 13 END IF allocate( id%JCN( id%NZ ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NZ IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'JCN' END IF GOTO 13 END IF END IF 13 CONTINUE CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN IF ( id%MYID .EQ. MASTER ) THEN DO I = 1, id%NPROCS - 1 CALL MPI_RECV( REQPTR( I+1, 1 ), 1, & MPI_INTEGER, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) END DO IF ( id%KEEP(46) .eq. 0 ) THEN REQPTR( 1, 1 ) = 1 ELSE REQPTR( 1, 1 ) = id%NZ_loc + 1 END IF DO I = 2, id%NPROCS REQPTR( I, 1 ) = REQPTR( I, 1 ) + REQPTR( I-1, 1 ) END DO ELSE CALL MPI_SEND( id%NZ_loc, 1, MPI_INTEGER, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN NRECV = 0 DO I = 1, id%NPROCS - 1 IF ( REQPTR( I + 1, 1 ) - REQPTR( I, 1 ) .NE. 0 ) THEN NRECV = NRECV + 2 CALL MPI_IRECV( id%IRN( REQPTR( I, 1 ) ), & REQPTR( I + 1, 1 ) - REQPTR( I, 1 ), & MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I, 2), IERR ) CALL MPI_IRECV( id%JCN( REQPTR( I, 1 ) ), & REQPTR( I + 1, 1 ) - REQPTR( I, 1 ), & MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I, 3), IERR ) ELSE REQPTR(I, 2) = MPI_REQUEST_NULL REQPTR(I, 3) = MPI_REQUEST_NULL END IF END DO ELSE IF ( id%NZ_loc .NE. 0 ) THEN CALL MPI_SEND( id%IRN_loc(1), id%NZ_loc, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(1), id%NZ_loc, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END IF END IF IF ( id%MYID .eq. MASTER ) THEN IF ( id%NZ_loc .NE. 0 ) THEN DO I=1,id%NZ_loc id%IRN(I) = id%IRN_loc(I) id%JCN(I) = id%JCN_loc(I) ENDDO END IF REQPTR( id%NPROCS, 2 ) = MPI_REQUEST_NULL REQPTR( id%NPROCS, 3 ) = MPI_REQUEST_NULL DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * id%NPROCS, REQPTR( 1, 2 ), INDX, STATUS, IERR ) END DO deallocate( REQPTR ) END IF RETURN 150 FORMAT( &/' ** FAILURE DURING ZMUMPS_664, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE ZMUMPS_664 SUBROUTINE ZMUMPS_658(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(ZMUMPS_STRUC) :: id 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) IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (id%MYID.EQ.MASTER .AND. .NOT. IS_DISTRIBUTED) THEN IF (id%WRITE_PROBLEM(1:20) .NE. "NAME_NOT_INITIALIZED")THEN OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL ZMUMPS_166( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL ) CLOSE(IUNIT) ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN 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) IF (MM_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(MM_IDSTR,'(I7)') id%MYID_NODES OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(MM_IDSTR))) CALL ZMUMPS_166(id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL ) CLOSE(IUNIT) ENDIF ENDIF 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_179(IUNIT, id) CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE ZMUMPS_658 SUBROUTINE ZMUMPS_166 & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL INTEGER, intent(in) :: IUNIT TYPE(ZMUMPS_STRUC), intent(in) :: id CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER :: I IF (IS_ELEMENTAL) THEN RETURN ENDIF IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED) THEN IF (associated(id%A)) 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, id%NZ IF (associated(id%A)) THEN DO I=1,id%NZ IF (id%KEEP(50).NE.0 .AND. id%IRN(I).LT.id%JCN(I)) THEN WRITE(IUNIT,*) id%JCN(I), id%IRN(I), & dble(id%A(I)), aimag(id%A(I)) ELSE WRITE(IUNIT,*) id%IRN(I), id%JCN(I), & dble(id%A(I)), aimag(id%A(I)) ENDIF ENDDO ELSE DO I=1,id%NZ IF (id%KEEP(50).NE.0 .AND. id%IRN(I).LT.id%JCN(I)) THEN WRITE(IUNIT,*) id%JCN(I), id%IRN(I) ELSE WRITE(IUNIT,*) id%IRN(I), id%JCN(I) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN 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, id%NZ_loc IF (associated(id%A_loc)) THEN DO I=1,id%NZ_loc IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I), & dble(id%A_loc(I)), aimag(id%A_loc(I)) ELSE WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I), & dble(id%A_loc(I)), aimag(id%A_loc(I)) ENDIF ENDDO ELSE DO I=1,id%NZ_loc IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I) ELSE WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_166 SUBROUTINE ZMUMPS_179(IUNIT, id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT CHARACTER (LEN=8) :: ARITH INTEGER :: I, J, K, LD_RHS 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_179 SUBROUTINE ZMUMPS_649( NSLAVES, NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND 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 RETURN END SUBROUTINE ZMUMPS_649 SUBROUTINE ZMUMPS_251(N,IW,LIW,A,LA, & NSTK_STEPS, NBPROCFILS,IFLAG,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, IERROR,IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, & LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST_S, 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) USE ZMUMPS_LOAD USE ZMUMPS_OOC IMPLICIT NONE INCLUDE 'zmumps_root.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER N,IFLAG,NTOTPV,MAXFRT,LIW, LPTRAR, NMAXNPIV, & IERROR, 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 PTRARW(LPTRAR), PTRAIW(LPTRAR), ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST_S(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 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 ) INTEGER INTARR( max(1,KEEP(14)) ) COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) LOGICAL IS_ISOLATED_NODE INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(30) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBRTOT, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS 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_330, MUMPS_275 INTEGER MUMPS_330, MUMPS_275 LOGICAL MUMPS_167,MUMPS_283 EXTERNAL MUMPS_167,MUMPS_283 LOGICAL ZMUMPS_508 EXTERNAL ZMUMPS_508, ZMUMPS_509 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 ASS_IRECV = MPI_REQUEST_NULL ITLOC(1:N+KEEP(253)) =0 PTRIST (1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRAST(1:KEEP(28))=0_8 PTRFAC(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_22( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, & IFLAG, IERROR & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 NBPROCFILS(1:KEEP(28)) = 0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL ZMUMPS_284( & 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, IFLAG, KEEP,KEEP8, IERROR ) ENDIF IF ( IFLAG .LT. 0 ) GOTO 635 END IF 20 CONTINUE NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( & 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_STEPS, & COMP, IFLAG, & IERROR, COMM_NODES, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED ) CALL ZMUMPS_467(COMM_LOAD, KEEP) IF (MESSAGE_RECEIVED) THEN IF ( IFLAG .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. ZMUMPS_508( IPOOL, LPOOL) )THEN CALL ZMUMPS_509( 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_500( & 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_501( & 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_512(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_242(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_330(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_144( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, & NPVW, & COMM_NODES, MYID_NODES, 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_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) IF ( IFLAG .LT. 0 ) GOTO 640 ELSE CALL ZMUMPS_141( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, & NPVW, & COMM_NODES, MYID_NODES, 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_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) IF ( IFLAG .LT. 0 ) GOTO 640 IF ( IW( PTLUST_S(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_176( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & IFLAG, IERROR, COMM_NODES, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL ZMUMPS_36( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ELSE JOBASS = 0 CALL ZMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF IF ( IFLAG .LT. 0 ) GOTO 640 IF ((NBPROCFILS(STEP(INODE)).GT.0).OR.(SON_LEVEL2)) GOTO 20 ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL ZMUMPS_253(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & IFLAG, IERROR, & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & ) ELSE CALL ZMUMPS_37( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, IFLAG, IERROR, & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0)) END IF IF (IFLAG.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_251", POSELT CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_87 & ( IW(PTLUST_S(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST_S(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_143( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & IFLAG, UU, NOFFW, NPVW, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL ZMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL ZMUMPS_140( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & IFLAG, UU, NOFFW, NPVW, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL ZMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_330(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) ELSE TYPEF = -9999 END IF CALL ZMUMPS_254( 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,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 ) IF (IFLAG.LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in ZMUMPS_251: ', & ' 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_681(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL ZMUMPS_580(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in ZMUMPS_251: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in ZMUMPS_251: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL ZMUMPS_242( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_275(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_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF)) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL ZMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE CALL ZMUMPS_44( MYID_NODES, SLAVEF, COMM_NODES ) 640 CONTINUE CALL ZMUMPS_255( INFO(1), & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL ZMUMPS_180( INFO(1), & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, MP) 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_275( & 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_S(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_731(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before ZMUMPS_146', LBUFRX CALL MUMPS_ABORT() ENDIF IS_BUFRX_ALLOCATED = .FALSE. ENDIF CALL ZMUMPS_146( MYID_NODES, & root, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST_S, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_275(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_729(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 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL ZMUMPS_688 & ( 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_576(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in ZMUMPS_576' CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 IF (KEEP(252).NE.0) THEN CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLU) ELSE CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLU) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLU) 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_731(LRHS_CNTR_MASTER_ROOT,INFO(2)) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before ZMUMPS_146', & 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_156( 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_S(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 CALL ZMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-NFRONT8*NFRONT8,KEEP,KEEP8,LRLU) ENDIF ENDIF END IF END IF END IF IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_275(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_251 SUBROUTINE ZMUMPS_87( 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' CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE ZMUMPS_87 SUBROUTINE ZMUMPS_136( id ) USE ZMUMPS_OOC USE ZMUMPS_STRUC_DEF USE ZMUMPS_COMM_BUFFER IMPLICIT NONE include 'mpif.h' TYPE( ZMUMPS_STRUC ) :: id LOGICAL I_AM_SLAVE INTEGER IERR, MASTER PARAMETER ( MASTER = 0 ) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL ZMUMPS_587(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_276(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 CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF NULLIFY(id%SCHUR_CINTERFACE) 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%POIDS)) THEN DEALLOCATE(id%POIDS) NULLIFY(id%POIDS) ENDIF 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 IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF 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) ENDIF IF (associated(id%POSINRHSCOMP)) THEN DEALLOCATE(id%POSINRHSCOMP) NULLIFY(id%POSINRHSCOMP) ENDIF 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 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_636(id) IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF 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 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%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%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 IF (id%KEEP8(24).EQ.0_8) THEN IF (associated(id%S)) DEALLOCATE(id%S) ELSE ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN CALL ZMUMPS_57( IERR ) CALL ZMUMPS_59( IERR ) END IF IF ( associated( id%BUFR ) ) DEALLOCATE( id%BUFR ) NULLIFY( id%BUFR ) RETURN END SUBROUTINE ZMUMPS_136 SUBROUTINE ZMUMPS_150(MYID,COMM,S,MAXS,MAXS_BYTES) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) INTEGER COMM, MYID, MAXS, MAXS_BYTES INTEGER S( MAXS ) INTEGER MSGTAG, MSGSOU, MSGLEN LOGICAL FLAG FLAG = .TRUE. DO WHILE ( FLAG ) CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) IF (FLAG) THEN MSGTAG=STATUS(MPI_TAG) MSGSOU=STATUS(MPI_SOURCE) CALL MPI_GET_COUNT(STATUS,MPI_PACKED,MSGLEN,IERR) IF (MSGLEN <= MAXS_BYTES) THEN CALL MPI_RECV(S(1),MAXS_BYTES,MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR) ELSE EXIT ENDIF END IF END DO CALL MPI_BARRIER( COMM, IERR ) RETURN END SUBROUTINE ZMUMPS_150 SUBROUTINE ZMUMPS_254(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, & 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 ) USE ZMUMPS_COMM_BUFFER 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) 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) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) INTEGER INTARR(max(1,KEEP(14))) 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 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_275 EXTERNAL MUMPS_275 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_167, &MUMPS_170 EXTERNAL MUMPS_167, MUMPS_170 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_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SSARBR_ROOT = MUMPS_170 & (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(*,*) "Error 1 in G" 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_511( 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_190(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_511( 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_190(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_511(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (SSARBR_ROOT) THEN CALL ZMUMPS_190(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL ZMUMPS_190(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_80( & 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, .FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_275(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_273( 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, & COMM, COMM_LOAD, FILS, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL ZMUMPS_76( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_329( 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, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE.) 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_275(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_275( 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_66( 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, IERR ) ELSE IF ( (TYPE.EQ.2).AND.(KEEP(48).NE.0)) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL ZMUMPS_70( 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_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_254", 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_254", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_275(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_22( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,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_275(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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_652( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, COMPRESSCB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL ZMUMPS_705( 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_651( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED ) 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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_93(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1) CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE ZMUMPS_254 SUBROUTINE ZMUMPS_142( id) USE ZMUMPS_COMM_BUFFER USE ZMUMPS_LOAD USE ZMUMPS_OOC USE ZMUMPS_STRUC_DEF IMPLICIT NONE #ifndef SUN_ INTERFACE SUBROUTINE ZMUMPS_27(id, ANORMINF, LSCAL) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id DOUBLE PRECISION, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL END SUBROUTINE ZMUMPS_27 END INTERFACE #endif TYPE(ZMUMPS_STRUC), TARGET :: id INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INCLUDE 'mumps_headers.h' INTEGER NSEND, NSEND_TOT, LDPTRAR, NELT INTEGER NLOCAL, NLOCAL_TOT, KEEP13_SAVE, ITMP INTEGER(8) K67 INTEGER(8) ITMP8 INTEGER MUMPS_275 EXTERNAL MUMPS_275 INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL INTEGER ZMUMPS_LBUF, ZMUMPS_LBUFR_BYTES, ZMUMPS_LBUF_INT INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, NSTEPS, K28, LPOOL, LIW INTEGER IRANK, ID_ROOT INTEGER KKKK, NZ_locMAX 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 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233 INTEGER COLOUR, COMM_FOR_SCALING INTEGER LIWK, LWK, LWK_REAL LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED 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, 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 INTEGER, POINTER :: JOB, NZ DOUBLE PRECISION,DIMENSION(:),POINTER::RINFO, RINFOG DOUBLE PRECISION,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER::INFO, 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(8),DIMENSION(:),POINTER::KEEP8 INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL ZMUMPS_505 INTEGER ZMUMPS_505 INTEGER(8) TOTAL_BYTES INTEGER(8) :: I8TMP INTEGER numroc EXTERNAL numroc COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED JOB=>id%JOB NZ=>id%NZ RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFO=>id%INFO INFOG=>id%INFOG KEEP=>id%KEEP KEEP8=>id%KEEP8 ICNTL=>id%ICNTL IF (id%NZ_loc .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 ) NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. IF (KEEP8(24).GT.0_8) THEN NULLIFY(id%S) ENDIF WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN KEEP8(24) = int(id%LWK_USER,8) ELSE KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE KEEP8(24) = 0_8 ENDIF KEEP13_SAVE = KEEP(13) id%DKEEP(4)=-1.0D0 id%DKEEP(5)=-1.0D0 MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LP = ICNTL( 1 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) 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. 0 ) 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 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN KEEP(201)=id%ICNTL(22) IF (KEEP(201) .NE. 0) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF 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(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 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 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 IF ( KEEP(50) .eq. 1 ) THEN IF (id%CNTL(1) .ne. ZERO ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') &' ** Warning : SPD solver called, resetting CNTL(1) to 0.0D0' END IF END IF id%CNTL(1) = ZERO END IF IF (KEEP(219).NE.0) THEN CALL ZMUMPS_617(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN INFO(1) = -13 INFO(2) = max(KEEP(108),1) END IF ENDIF IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN 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 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: sparse RHS incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 IF ( PROKG ) THEN WRITE( MPG, 172 ) id%NSLAVES, id%ICNTL(22), & KEEP8(111), KEEP(126), KEEP(127), KEEP(28) IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) ENDIF IF (KEEP(201).LE.0) THEN KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF 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 KEEP(260) = 1 id%DKEEP(6) = 1.0D0 id%DKEEP(7) = 0.0D0 ENDIF 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 IF ( id%MYID.EQ.MASTER ) THEN ENDIF IF (KEEP(52) .EQ. 7) THEN K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN 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 INFO(1)=-13 INFO(2)=LIWK+M+N+4* (id%NPROCS) ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 BUJOB = 1 LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL)) CALL ZMUMPS_693( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%NZ_loc, & 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 INFO(1)=-13 INFO(2)=LIWK ENDIF ENDIF LWK_REAL = BURESZ DEALLOCATE(WK_REAL) ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=LWK_REAL ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 BUJOB = 2 CALL ZMUMPS_693( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%NZ_loc, & 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 DEALLOCATE(IWK, WK_REAL,BURP,BUCP,BURS, BUCS) ELSE IF ( KEEP(54) .EQ. 0 ) THEN IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN 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 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 INFO(1)=-13 INFO(2)=1 ENDIF IF (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_693( & id%IRN(1), id%JCN(1), id%A(1), & id%NZ, & 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 INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL ZMUMPS_693(id%IRN(1), & id%JCN(1), id%A(1), & id%NZ, & 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 DEALLOCATE(WK_REAL) DEALLOCATE (IWK,BURP,BUCP, & BURS,BUCS) ENDIF CALL MPI_BCAST( id%DKEEP(4),2,MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) 400 CONTINUE IF (id%MYID.EQ.MASTER) THEN CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF (INFO(1).LT.0) GOTO 530 ELSE IF (id%MYID.EQ.MASTER) THEN IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN IF ( KEEP(52) .eq. 5 .or. & KEEP(52) .eq. 6 ) THEN LWK = NZ ELSE LWK = 1 END IF LWK_REAL = 5 * N ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK_REAL GOTO 137 END IF ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK GOTO 137 END IF CALL ZMUMPS_217(N, NZ, 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), INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN 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 = (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_761(id%ROWSCA(I), & id%DKEEP(6), & KEEP(259)) ENDDO IF (KEEP(50) .EQ. 0) THEN DO I = 1, id%N CALL ZMUMPS_761(id%COLSCA(I), & id%DKEEP(6), & KEEP(259)) ENDDO ELSE CALL ZMUMPS_765(id%DKEEP(6), KEEP(259)) ENDIF CALL ZMUMPS_766(id%DKEEP(6), KEEP(259)) ENDIF 137 CONTINUE 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 ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N id%KEEP(255) = N*id%KEEP(253) ALLOCATE(RHS_MUMPS(id%KEEP(255)),stat=IERR) IF (IERR > 0) THEN INFO(1)=-13 INFO(2)=id%KEEP(255) IF (LP > 0) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ELSE id%KEEP(254)=id%LRHS id%KEEP(255)=id%LRHS*(id%KEEP(253)-1)+id%N RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN 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 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 ELSE id%KEEP(255)=1 ALLOCATE(RHS_MUMPS(1)) RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).lt.0 ) GOTO 530 KEEP(110)=ICNTL(24) CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(110).NE.1) KEEP(110)=0 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) ANORMINF = ZERO IF (KEEP(19).EQ.0) THEN SEUIL = ZERO ELSE CALL ZMUMPS_27( id , ANORMINF, LSCAL ) IF (CNTL6 .LT. ZERO) THEN SEUIL = EPS*ANORMINF ELSE SEUIL = CNTL6*ANORMINF ENDIF IF (PROKG) WRITE(MPG,*) & ' ABSOLUTE PIVOT THRESHOLD for rank revealing =',SEUIL ENDIF SEUIL_LDLT_NIV2 = SEUIL IF (KEEP(110).EQ.0) THEN id%DKEEP(1) = -1.0D0 id%DKEEP(2) = ZERO ELSE IF (ANORMINF.EQ.ZERO) & CALL ZMUMPS_27( id , ANORMINF, LSCAL ) IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE id%DKEEP(1) = 1.0D-5*EPS*ANORMINF 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 id%DKEEP(2) = -max(1.0D10*ANORMINF, & sqrt(huge(ANORMINF))/1.0D8) ELSE id%DKEEP(2) = ZERO ENDIF ENDIF ENDIF IF (KEEP(53).NE.0) THEN ID_ROOT =MUMPS_275(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%NSLAVES) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF IF ( associated( id%PIVNUL_LIST) ) DEALLOCATE(id%PIVNUL_LIST) IF(KEEP(110) .EQ. 1) THEN LPN_LIST = N ELSE LPN_LIST = 1 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 INFO(1)=-13 INFO(2)=LPN_LIST END IF id%PIVNUL_LIST(1:LPN_LIST) = 0 KEEP(109) = 0 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).lt.0 ) GOTO 530 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN IF(ANORMINF .EQ. ZERO) THEN CALL ZMUMPS_27( id , ANORMINF, LSCAL ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL ELSE SEUIL = ZERO ENDIF ENDIF KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 IF ( id%MYID.EQ.MASTER ) THEN ITMP = ICNTL(23) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (WK_USER_PROVIDED) ITMP = 0 ITMP8 = int(ITMP, 8) KEEP8(4) = ITMP8 * 1000000_8 PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8=KEEP8(12) ELSE MAXS_BASE8=KEEP8(14) ENDIF IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) ELSE IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) IF (MAXS_BASE_RELAXED8 > huge(MAXS)) THEN WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ENDIF MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) MAXS = MAXS_BASE_RELAXED8 ELSE MAXS = 1_8 MAXS_BASE_RELAXED8 = 1_8 END IF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) .LT. 0) THEN GOTO 530 ENDIF IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN IF (KEEP(96).GT.0) THEN MAXS=int(KEEP(96),8) ELSE IF (KEEP8(4) .NE. 0_8) THEN PERLU_ON = .TRUE. CALL ZMUMPS_214( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., KEEP(201), & PERLU_ON, TOTAL_BYTES) MAXS_BASE_RELAXED8=MAXS_BASE_RELAXED8 + & (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 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,4) ELSE MAXS=MAXS_BASE_RELAXED8 ENDIF ENDIF ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) .LT. 0) THEN GOTO 530 ENDIF CALL ZMUMPS_713(PROKG, MPG, MAXS, id%NSLAVES, & id%COMM, "effective relaxed size of S =") CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF IF ( I_AM_SLAVE ) THEN CALL ZMUMPS_188( dble(id%COST_SUBTREES), & KEEP(64), KEEP(66),MAXS ) K28=KEEP(28) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), & max(0_8, MAXS-MAXS_BASE8)) CALL ZMUMPS_185( id, MEMORY_MD_ARG, MAXS ) CALL ZMUMPS_587(id, IERR) IF (IERR < 0) THEN INFO(1) = -90 INFO(2) = 0 GOTO 112 ENDIF IF (KEEP(201) .GT. 0) THEN IF (KEEP(201).EQ.1 & .AND.KEEP(50).EQ.0 & .AND.KEEP(251).NE.2 & ) THEN OOC_NB_FILE_TYPE=2 ELSE OOC_NB_FILE_TYPE=1 ENDIF IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN I8TMP = int(OOC_NB_FILE_TYPE,8) * 2_8 * int(KEEP(226),8) ELSE I8TMP = 2_8 * KEEP8(119) ENDIF I8TMP = I8TMP + int(max(KEEP(12),0),8) * & (I8TMP/100_8+1_8) I8TMP = min(I8TMP, 12000000_8) KEEP(100)=int(I8TMP) ENDIF IF (KEEP(201).EQ.1) THEN IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF IF (id%MYID_NODES .eq. MASTER) THEN write(6,*) ' PANEL: INIT and force STRAT_IO= ', & id%KEEP(99) ENDIF ENDIF 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), & OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) < 0) THEN 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_575(id,MAXS) ELSE WRITE(*,*) "Internal error in ZMUMPS_142" CALL MUMPS_ABORT() ENDIF IF(INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF #if ! defined(OLD_LOAD_MECHANISM) CALL ZMUMPS_190(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) #endif IF (INFO(1).LT.0) GOTO 111 #if defined(stephinfo) write(*,*) 'proc ',id%MYID,' array of dist : ', & id%MEM_DIST(0:id%NSLAVES - 1) #endif END IF IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN ALLOCATE (id%S(MAXS),stat=IERR) KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_735(MAXS, INFO(2)) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ELSE id%S => id%WK_USER(1:KEEP8(24)) ENDIF #if defined (LARGEMATRICES) END IF #endif 111 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP(55) .eq. 0 ) THEN IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE .and. KEEP(13) .ne. 0 ) THEN ALLOCATE( id%DBLARR( KEEP(13) ), stat = IERR ) ELSE ALLOCATE( id%DBLARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID, & ':Error allocating DBLARR : IERR = ', IERR INFO(1)=-13 INFO(2)=KEEP(13) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( I_AM_SLAVE .and. KEEP(14) .ne. 0 ) THEN ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = KEEP(14) 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 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 id%DBLARR => id%A_ELT ELSE IF ( KEEP(13) .ne. 0 ) THEN ALLOCATE( id%DBLARR( KEEP(13) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = KEEP(13) 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 IF ( KEEP(38).NE.0 .AND. I_AM_SLAVE ) THEN CALL ZMUMPS_165( id%N, & id%root, id%FILS(1), KEEP(38), id%KEEP(1), id%INFO(1) ) END IF 100 CONTINUE CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP( 55 ) .eq. 0 ) THEN IF (KEEP(38).NE.0 .AND. I_AM_SLAVE) THEN LWK = numroc( id%root%ROOT_SIZE, id%root%MBLOCK, & id%root%MYROW, 0, id%root%NPROW ) LWK = max( 1, LWK ) LWK = LWK* & numroc( id%root%ROOT_SIZE, id%root%NBLOCK, & id%root%MYCOL, 0, id%root%NPCOL ) LWK = max( 1, LWK ) ELSE LWK = 1 ENDIF IF (MAXS .LT. int(LWK,8)) THEN INFO(1) = -9 INFO(2) = LWK ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN ALLOCATE(IWK(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN INFO(1)=-13 INFO(2)=id%N END IF #if defined(LARGEMATRICES) IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( .not. associated( id%INTARR ) ) THEN ALLOCATE( id%INTARR( 1 ) ) ENDIF #if defined(LARGEMATRICES) CALL ZMUMPS_148(id%N, NZ, 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), & min(KEEP(39),id%NZ), & LP, id%COMM, id%root, KEEP,KEEP8, & id%FILS(1), IWK(1), & & id%INTARR(1), id%DBLARR(1), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), int(LWK,8), & id%ISTEP_TO_INIV2, id%I_AM_CAND, & id%CANDIDATES) write(6,*) '!!! A,IRN,JCN are freed during facto ' 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) KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = MAXS NULLIFY(id%S) KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ELSE id%S => id%WK_USER(1:KEEP8(24)) ENDIF id%S(MAXS-LWK+1:MAXS) = WK(1:LWK) DEALLOCATE (WK) #else CALL ZMUMPS_148(id%N, NZ, 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), & min(KEEP(39),id%NZ), & LP, id%COMM, id%root, KEEP(1),KEEP8(1), & id%FILS(1), IWK(1), & & id%INTARR(1), id%DBLARR(1), & 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) IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF ELSE CALL ZMUMPS_145( id%N, & id%DBLARR( 1 ), max(1,KEEP( 13 )), & id%INTARR( 1 ), max(1,KEEP( 14 )), & id%PTRAR( 1 ), & id%PTRAR(id%N+1), & KEEP( 1 ), KEEP8(1), id%MYID, id%COMM, & min(id%KEEP(39),id%NZ), & & 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 IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( I_AM_SLAVE ) THEN NZ_locMAX = 0 CALL MPI_ALLREDUCE(id%NZ_loc, NZ_locMAX, 1, MPI_INTEGER, & MPI_MAX, id%COMM_NODES, IERR) CALL ZMUMPS_282( id%N, & id%NZ_loc, & id, & id%DBLARR(1), KEEP(13), id%INTARR(1), & KEEP(14), id%PTRAR(1), id%PTRAR(id%N+1), & KEEP(1), KEEP8(1), id%MYID_NODES, & id%COMM_NODES, min(id%KEEP(39),NZ_locMAX), & 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), NSEND, NLOCAL, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN 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) 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) NLOCAL, NSEND END IF END IF IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN NSEND = 0 NLOCAL = 0 END IF CALL MPI_REDUCE( NSEND, NSEND_TOT, 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL, NLOCAL_TOT, 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT, NSEND_TOT END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF END IF ELSE IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( id%MYID.eq.MASTER) &CALL ZMUMPS_213( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) CALL ZMUMPS_126( id%N, id%NELT, id%NA_ELT, & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & id%INTARR(1), id%DBLARR(1), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & id%S(1), MAXS, id%FILS(1), & id, id%root ) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF END IF IF ( I_AM_SLAVE ) THEN CALL ZMUMPS_528(id%MYID_NODES) ZMUMPS_LBUFR_BYTES = KEEP( 44 ) * KEEP( 35 ) ZMUMPS_LBUFR_BYTES = max( ZMUMPS_LBUFR_BYTES, & 100000 ) PERLU = KEEP( 12 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF ZMUMPS_LBUFR_BYTES = ZMUMPS_LBUFR_BYTES & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUFR_BYTES)/100D0) IF (KEEP(48)==5) THEN KEEP8(21) = KEEP8(22) + int( dble(max(PERLU,MIN_PERLU))* & dble(KEEP8(22))/100D0,8) ENDIF ZMUMPS_LBUF = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(43)) * dble(KEEP(35)) ) ZMUMPS_LBUF = max( ZMUMPS_LBUF, 100000 ) ZMUMPS_LBUF = ZMUMPS_LBUF & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUF)/100D0) ZMUMPS_LBUF = max(ZMUMPS_LBUF, ZMUMPS_LBUFR_BYTES+3*KEEP(34)) IF(id%KEEP(48).EQ.4)THEN ZMUMPS_LBUFR_BYTES=ZMUMPS_LBUFR_BYTES*5 ZMUMPS_LBUF=ZMUMPS_LBUF*5 ENDIF ZMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN KKKK = MUMPS_275( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%NSLAVES ) IF ( KKKK .EQ. id%MYID_NODES ) THEN ZMUMPS_LBUF_INT = ZMUMPS_LBUF_INT + & 10 * & 2 * ( id%NE_STEPS(id%STEP(KEEP(38))) + 1 ) * id%NSLAVES & * KEEP(34) END IF END IF IF ( MP .GT. 0 ) 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) CALL ZMUMPS_55( ZMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID, & ':Error allocating small Send buffer:IERR=' & ,IERR INFO(1)= -13 INFO(2)= (ZMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) GO TO 110 END IF CALL ZMUMPS_53( ZMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating Send buffer:IERR=' & ,IERR INFO(1)= -13 INFO(2)= (ZMUMPS_LBUF+KEEP(34)-1)/KEEP(34) GO TO 110 END IF 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 WRITE(*,*) id%MYID,':Error allocating BUFR:IERR=' & ,IERR INFO(1)=-13 INFO(2)=id%LBUFR NULLIFY(id%BUFR) GO TO 110 END IF PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN MAXIS_ESTIM = KEEP(225) ELSE 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 WRITE(*,*) id%MYID,':Error allocating IS:IERR=',IERR INFO(1)=-13 INFO(2)=MAXIS NULLIFY(id%IS) GO TO 110 END IF LIW = MAXIS IF (associated( id%PTLUST_S )) DEALLOCATE(id%PTLUST_S) ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocatingPTLUST:IERR = ', & IERR INFO(1)=-13 INFO(2)=id%KEEP(28) 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 WRITE(*,*) id%MYID,':Error allocatingPTRFAC:IERR = ', & IERR INFO(1)=-13 INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) GOTO 100 END IF PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 3 * id%KEEP(28) IPOOL = ITLOC + id%N + id%KEEP(253) LPOOL = ZMUMPS_505(id%KEEP(1),id%KEEP8(1)) ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', & IERR INFO(1)=-13 INFO(2)=IPOOL + LPOOL - 1 GOTO 110 END IF ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', & IERR INFO(1)=-13 INFO(2)=2 * id%KEEP(28) GOTO 110 END IF ENDIF 110 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN CALL ZMUMPS_60( id%LBUFR_BYTES ) IF (MP .GT. 0) THEN WRITE( MP, 170 ) MAXS, MAXIS, KEEP8(12), KEEP(15), KEEP(13), & KEEP(14), KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF PERLU_ON = .TRUE. CALL ZMUMPS_214( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) id%INFO(16) = TOTAL_MBYTES IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' ** Space in MBYTES used during factorization :', & id%INFO(16) END IF CALL MUMPS_243( 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 KEEP8(31)= 0_8 KEEP8(10) = 0_8 KEEP8(8)=0_8 INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = id%N ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT = id%NELT ELSE NELT = 1 END IF CALL ZMUMPS_244( 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), INFO(1), RINFO(1), KEEP(1),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, 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) IF ( MP . GT. 0 .and. KEEP(38) .ne. 0 ) THEN WRITE( MP, 175 ) KEEP(49) END IF DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF IF ( KEEP(55) .eq. 0 ) THEN IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF ELSE DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN NULLIFY( id%DBLARR ) ELSE IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF END IF IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN 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 IF (associated(id%BUFR)) THEN DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) END IF CALL ZMUMPS_57( IERR ) CALL ZMUMPS_59( IERR ) IF (KEEP(219).NE.0) THEN CALL ZMUMPS_620() ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) CALL ZMUMPS_770(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_591(IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ENDIF ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) END IF END IF IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,180) TIME END IF PERLU_ON = .TRUE. CALL ZMUMPS_214( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) KEEP8(7) = TOTAL_BYTES id%INFO(22) = TOTAL_MBYTES IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' ** Effective minimum Space in MBYTES for facto :', & TOTAL_MBYTES ENDIF IF (I_AM_SLAVE) THEN K67 = KEEP8(67) ELSE K67 = 0_8 ENDIF CALL MUMPS_735(K67,id%INFO(21)) CALL ZMUMPS_713(PROKG, MPG, K67, id%NSLAVES, & id%COMM, "effective space used in S (KEEP8(67) =") CALL MUMPS_243( 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 KEEP(33) = INFO(11) CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_646( KEEP8(31),KEEP8(6), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(6), INFOG(9)) CALL MPI_REDUCE( INFO(10), INFOG(10), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_ALLREDUCE( INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) KEEP(133) = INFOG(11) CALL MPI_REDUCE( 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) INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) CALL MUMPS_646( KEEP8(8), KEEP8(108), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(10), INFO(27)) CALL MUMPS_646( KEEP8(10),KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(110), INFOG(29)) IF (KEEP(258).NE.0) THEN IF (KEEP(260).EQ.-1) THEN id%DKEEP(6)=-id%DKEEP(6) id%DKEEP(7)=-id%DKEEP(7) ENDIF CALL ZMUMPS_764( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN IF (id%KEEP(23).NE.0) THEN CALL ZMUMPS_767( & RINFOG(12), id%N, & id%STEP(1), & id%UNS_PERM(1) ) ENDIF ENDIF ENDIF IF(KEEP(110) .EQ. 1) THEN INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF INFOG(28)=KEEP(112)+KEEP(17) IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN INFO(18)=INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN DO I=1, KEEP(17) id%PIVNUL_LIST(KEEP(112)+I)=id%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE 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 IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%NPROCS END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (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 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) 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 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) IF ( PROKG ) THEN WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP8(6),INFOG(10), & INFOG(11), KEEP8(110) IF (id%KEEP(50) == 0) THEN WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN WRITE(MPG, 99986) KEEP(98) ENDIF IF (id%KEEP(50) == 2) THEN WRITE(MPG, 99988) KEEP(229) WRITE(MPG, 99989) KEEP(230) ENDIF IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) IF (KEEP(110).NE.0.OR.KEEP(17).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) WRITE(MPG, 99981) INFOG(14) IF ((KEEP(201).EQ.0.OR.KEEP(201).EQ.2).AND. & KEEP(50).EQ.0) THEN WRITE(MPG, 99980) KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN 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 500 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL ZMUMPS_592(id,IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ELSE IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 END IF END IF 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL ZMUMPS_183( INFO(1), IERR ) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) 530 CONTINUE IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) id%KEEP(13) = KEEP13_SAVE RETURN 120 FORMAT(/' LOCAL REDISTRIB: DATA LOCAL/SENT =',I12,I12) 125 FORMAT(/' REDISTRIB: TOTAL DATA LOCAL/SENT =',I12,I12) 130 FORMAT(/' ****** FACTORIZATION STEP ********'/) 160 FORMAT(' GLOBAL TIME FOR MATRIX DISTRIBUTION =',F12.4) 165 FORMAT(' Convergence error after scaling for INF-NORM', & ' (option 7/8) =',D9.2) 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 =',I12/ & ' Size of internal working array IS =',I12/ & ' MINIMUM (ICNTL(14)=0) size of S =',I12/ & ' MINIMUM (ICNTL(14)=0) size of IS =',I12/ & ' REAL SPACE FOR ORIGINAL MATRIX =',I12/ & ' INTEGER SPACE FOR ORIGINAL MATRIX =',I12/ & ' REAL SPACE FOR FACTORS =',I12/ & ' INTEGER SPACE FOR FACTORS =',I12/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12) 172 FORMAT(/' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' NUMBER OF WORKING PROCESSES =',I12/ & ' OUT-OF-CORE OPTION (ICNTL(22)) =',I12/ & ' REAL SPACE FOR FACTORS =',I12/ & ' INTEGER SPACE FOR FACTORS =',I12/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12/ & ' NUMBER OF NODES IN THE TREE =',I12) 173 FORMAT( ' PERFORM FORWARD DURING FACTO, NRHS =',I12) 175 FORMAT(/' NUMBER OF ENTRIES FOR // ROOT =',I12) 180 FORMAT(/' ELAPSED TIME FOR FACTORIZATION =',F12.4) 99977 FORMAT( ' INFOG(34) DETERMINANT (base 2 exponent) =',I12) 99978 FORMAT( ' RINFOG(12) DETERMINANT (real part) =',F12.4) 99979 FORMAT( ' RINFOG(12) DETERMINANT (imaginary part) =',F12.4) 99980 FORMAT( ' KEEP8(108) Extra copies IP stacking =',I12) 99981 FORMAT( ' INFOG(14) NUMBER OF MEMORY COMPRESS =',I12) 99982 FORMAT( ' INFOG(13) NUMBER OF DELAYED PIVOTS =',I12) 99983 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(16) =',I12) 99991 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(24) =',I12) 99992 FORMAT( ' INFOG(28) ESTIMATED DEFICIENCY =',I12) 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 =',I12/ & ' INFOG(10) INTEGER SPACE FOR FACTORS =',I12/ & ' INFOG(11) MAXIMUM FRONT SIZE =',I12/ & ' INFOG(29) NUMBER OF ENTRIES IN FACTORS =',I12) 99985 FORMAT( ' INFOG(12) NB OF OFF DIAGONAL PIVOTS =',I12) 99986 FORMAT( ' INFOG(25) NB TINY PIVOTS/STATIC PIVOTING =',I12) 99988 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 1 nodes =',I12) 99989 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 2 nodes =',I12) END SUBROUTINE ZMUMPS_142 SUBROUTINE ZMUMPS_713(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 INTEGER(8) MAX_VAL INTEGER IERR, MASTER DOUBLE PRECISION LOC_VAL, AVG_VAL PARAMETER(MASTER=0) CALL MUMPS_646( 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,I12) END SUBROUTINE ZMUMPS_713 SUBROUTINE ZMUMPS_770(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR, MASTER 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 INTEGER MUMPS_275 EXTERNAL MUMPS_275 IF (id%INFO(1) .LT. 0) RETURN IF (id%KEEP(60) .EQ. 0) RETURN ID_SCHUR =MUMPS_275( & 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 IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE LD_SCHUR = -999999 SIZE_SCHUR = id%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ELSE RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN 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 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 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 IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF RETURN ENDIF IF (id%KEEP(252).EQ.0) THEN IF ( ID_SCHUR .EQ. MASTER ) THEN CALL ZMUMPS_756( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE BL8=int(huge(BL4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) IF ( id%MYID .eq. ID_SCHUR ) THEN 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 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 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 CALL zcopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_DOUBLE_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE 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 IF (id%KEEP(221).EQ.1) THEN 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 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 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_770 SUBROUTINE ZMUMPS_83 & ( N, MAPPING, NZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NZ, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NZ ), JCN( NZ ) INTEGER MAPPING( NZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_275, MUMPS_330 EXTERNAL MUMPS_275, MUMPS_330 INTEGER K, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K INODE = FILS( INODE ) K = K + 1 END DO DO K = 1, NZ IOLD = IRN( K ) JOLD = JCN( K ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K ) = -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_330( PROCNODE(abs(STEP(IARR))), & SLAVEF ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_275( PROCNODE(abs(STEP(IARR))), & SLAVEF ) + 1 ELSE DEST = MUMPS_275( 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( K ) = DEST END DO RETURN END SUBROUTINE ZMUMPS_83 SUBROUTINE ZMUMPS_282( & N, NZ_loc, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND, NLOCAL, & ISTEP_TO_INIV2, CANDIDATES & ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NZ_loc TYPE (ZMUMPS_STRUC) :: id INTEGER LDBLARR, LINTARR COMPLEX(kind=8) DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER 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_275, MUMPS_330, numroc, & MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, numroc, & MUMPS_810 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ), MSGSOU COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER END_MSG_2_RECV INTEGER I, K, I1, IA 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 IACT( SLAVEF ), IREQI( SLAVEF ), IREQR( SLAVEF ) LOGICAL SEND_ACTIVE( SLAVEF ) LOGICAL FLAG INTEGER NSEND, NLOCAL INTEGER MASTER_NODE, ISTEP NSEND = 0 NLOCAL = 0 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF 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 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_276( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) RETURN ARROW_ROOT = 0 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((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 K = 1, NZ_loc 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_102( & 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(K) JOLD = id%JCN_loc(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) CYCLE VAL = id%A_loc(K) 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_330( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE= MUMPS_275( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_810( 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 NLOCAL = NLOCAL + 1 NSEND = NSEND + SLAVEF -1 else if (DEST .eq.MYID ) then NLOCAL = NLOCAL + 1 else NSEND = NSEND + 1 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_101( 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_101( 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_101( 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_101( 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_101( 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_101( 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_102( & 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 DEALLOCATE( IW4 ) DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) DEALLOCATE( BUFRECI ) DEALLOCATE( BUFRECR ) RETURN END SUBROUTINE ZMUMPS_282 SUBROUTINE ZMUMPS_101( 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 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 PTRAIW( N ), PTRARW( N ), 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, 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_102( & 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_102( & 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_101 SUBROUTINE ZMUMPS_102 & ( 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 PTRAIW( N ), PTRARW( N ), PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA COMPLEX(kind=8) A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID, & ILOCROOT, JLOCROOT INTEGER IA, IS1, ISHIFT, IIW, IS, IAS, 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_330( & 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 IA = PTRARW(IARR) DBLARR(IA) = DBLARR(IA) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL ENDIF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IPROC = MUMPS_275( 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_310( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_102 SUBROUTINE ZMUMPS_151( NRHS, N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER NRHS, N,LIWW,LWC,POSWCB,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28),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 SIZFR = SIZFR * NRHS IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE ZMUMPS_151 SUBROUTINE ZMUMPS_95(NRHS,N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER NRHS,N,LIWW,LWC,POSWCB,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28),PTRACB(KEEP28) COMPLEX(kind=8) W(LWC) INTEGER IPTIW,IPTA,SIZFI,SIZFR,LONGI,LONGR INTEGER I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = IWCB(IPTIW+1) SIZFI = 2 SIZFR = SIZFR * NRHS IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I ) 20 CONTINUE DO 30 I=0,LONGR-1 W(IPTA + SIZFR - I) = W(IPTA - I ) 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 = IWCB(IPTIW+1) SIZFI = 2 SIZFR = SIZFR * NRHS IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE ZMUMPS_95 SUBROUTINE ZMUMPS_205(MTYPE, IFLAG, N, NZ, & LHS, WRHS, W, RHS, GIVSOL, SOL, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,NZ,IFLAG,ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) RHS(N),LHS(N) COMPLEX(kind=8) WRHS(N),SOL(*) DOUBLE PRECISION W(N) DOUBLE PRECISION RESMAX,RESL2,XNORM, ERMAX,MAXSOL, & COMAX, SCLNRM, ERL2, ERREL DOUBLE PRECISION ANORM,DZERO,EPSI LOGICAL GIVSOL,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0D0 EPSI = 0.1D-9 ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RHS(K))) RESL2 = RESL2 + abs(RHS(K)) * abs(RHS(K)) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF (XNORM .GT. EPSI) THEN SCLNRM = RESMAX / (ANORM * XNORM) ELSE IFLAG = IFLAG + 2 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) &' max-NORM of computed solut. is zero' SCLNRM = RESMAX / ANORM ENDIF RESL2 = sqrt(RESL2) ERMAX = DZERO COMAX = DZERO ERL2 = DZERO IF (.NOT.GIVSOL) THEN IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM ELSE MAXSOL = DZERO DO 60 K = 1, N MAXSOL = max(MAXSOL, abs(SOL(K))) 60 CONTINUE DO 70 K = 1, N ERL2 = abs(LHS(K) - SOL(K)) ** 2 + ERL2 ERMAX = max(ERMAX, abs(LHS(K) - SOL(K))) 70 CONTINUE DO 80 K = 1, N IF (abs(SOL(K)) .GT. EPSI) THEN COMAX = max(COMAX, (abs(LHS(K) - SOL(K)) / abs(SOL(K)))) ENDIF 80 CONTINUE ERL2 = sqrt(ERL2) IF (MAXSOL .GT. EPSI) THEN ERREL = ERMAX / MAXSOL ELSE IFLAG = IFLAG + 2 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) &' MAX-NORM of exact solution is zero' ERREL = ERMAX ENDIF IF (PROK) WRITE( MPRINT, 100 ) ERMAX, ERL2, ERREL, COMAX, RESMAX & , RESL2, ANORM, XNORM, SCLNRM ENDIF 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 100 FORMAT (/' ERROR IS ............ (MAX-NORM) =',1PD9.2/ & ' ............ (2-NORM) =',1PD9.2/ & ' RELATIVE ERROR........... (MAX-NORM) =',1PD9.2/ & ' Comp. Wise ERROR......... (MAX-NORM) =',1PD9.2/ & ' AND RESIDUAL IS ......... (MAX-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' NORM OF input MATRIX ... (MAX-NORM) =',1PD9.2/ & ' NORM of computed SOLUT... (MAX-NORM) =',1PD9.2/ & ' SCALED RESIDUAL ......... (MAX-NORM) =',1PD9.2) END SUBROUTINE ZMUMPS_205 SUBROUTINE ZMUMPS_206(NZ, N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, JOB, COND, MAXIT, NOITER, LP, KEEP,KEEP8, & ARRET ) IMPLICIT NONE INTEGER NZ, N, KASE, KEEP(500), JOB 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, MAXIT, NOITER DOUBLE PRECISION COND(2),OMEGA(2) DOUBLE PRECISION ARRET DOUBLE PRECISION CGCE, CTAU DATA CTAU /1.0D3/, CGCE /0.2D0/ LOGICAL LCOND1, LCOND2 INTEGER IFLAG, JUMP, I, IMAX DOUBLE PRECISION ERX, DXMAX DOUBLE PRECISION CONVER, OM1, OM2, DXIMAX DOUBLE PRECISION ZERO, ONE,TAU, DD DOUBLE PRECISION OLDOMG(2) INTEGER ZMUMPS_IXAMAX INTRINSIC abs, max SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX, CONVER, & OM1, OLDOMG, IFLAG DATA ZERO /0.0D0/, ONE /1.0D0/ IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO OM1 = ZERO IFLAG = 0 NOITER = 0 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 DO 20 I = 1, N X(I) = X(I) + Y(I) 20 CONTINUE IF (NOITER .GT. MAXIT) THEN IFLAG = IFLAG + 8 GOTO 70 ENDIF 30 CONTINUE KASE = 14 JUMP = 5 RETURN 35 CONTINUE IMAX = ZMUMPS_IXAMAX(N, X, 1) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO 40 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 + TAU) .GT. TAU) 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 40 CONTINUE OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) GOTO 70 IF (MAXIT .EQ. 0) GOTO 70 IF (NOITER .GT. 1 .AND. OM2 .GT. OM1 * CGCE) THEN CONVER = OM2 / OM1 IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO 50 I = 1, N X(I) = C_W(I) 50 CONTINUE ENDIF GOTO 70 ENDIF DO 60 I = 1, N C_W(I) = X(I) 60 CONTINUE OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 NOITER = NOITER + 1 KASE = 2 JUMP = 2 RETURN 70 KASE = 0 IF (JOB .LE. 0) GOTO 170 DO 80 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 80 CONTINUE DO 90 I = 1, N C_W(I) = X(I) * D(I) 90 CONTINUE IMAX = ZMUMPS_IXAMAX(N, C_W(1), 1) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CALL ZMUMPS_218(N, KASE, Y, COND(1), C_W, IW(1, 2)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL ZMUMPS_204(N, Y, D) IF (KASE .EQ. 2) CALL ZMUMPS_204(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL ZMUMPS_204(N, Y, R_W) IF (KASE .EQ. 2) CALL ZMUMPS_204(N, Y, D) GOTO 100 120 IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CALL ZMUMPS_218(N, KASE, Y, COND(2), C_W, IW(1, 2)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL ZMUMPS_204(N, Y, D) IF (KASE .EQ. 2) CALL ZMUMPS_204(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL ZMUMPS_204(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL ZMUMPS_204(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 KASE = -IFLAG RETURN END SUBROUTINE ZMUMPS_206 SUBROUTINE ZMUMPS_207(A, NZ, N, IRN, ICN, Z, KEEP,KEEP8) INTEGER NZ, N, I, J, K, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN(NZ), ICN(NZ) COMPLEX(kind=8) A(NZ) DOUBLE PRECISION Z(N) DOUBLE PRECISION ZERO INTRINSIC abs DATA ZERO /0.0D0/ DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1, NZ 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, NZ 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 RETURN END SUBROUTINE ZMUMPS_207 SUBROUTINE ZMUMPS_289(A, NZ, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA) INTEGER, intent(in) :: NZ, N, KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) COMPLEX(kind=8), intent(in) :: A(NZ) DOUBLE PRECISION, intent(in) :: COLSCA(N) DOUBLE PRECISION, intent(out) :: Z(N) DOUBLE PRECISION ZERO DATA ZERO /0.0D0/ INTEGER I, J, K DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1, NZ 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, NZ 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_289 SUBROUTINE ZMUMPS_208(A, NZ, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, intent(in) :: NZ, N, KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) COMPLEX(kind=8), intent(in) :: A(NZ), RHS(N), X(N) DOUBLE PRECISION, intent(out) :: W(N) COMPLEX(kind=8), intent(out) :: R(N) INTEGER I, K, J DOUBLE PRECISION ZERO DATA ZERO /0.0D0/ COMPLEX(kind=8) D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. (J .LT. 1)) & CYCLE D = A(K) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF ((I.NE.J) .AND. (KEEP(50).NE.0) ) THEN D = A(K) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_208 SUBROUTINE ZMUMPS_204(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_204 SUBROUTINE ZMUMPS_218(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 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_218 SUBROUTINE ZMUMPS_278( MTYPE, N, NZ, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N, NZ INTEGER IRN( NZ ), ICN( NZ ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8), intent(in) :: ASPK( NZ ) COMPLEX(kind=8), intent(in) :: LHS( N ), WRHS( N ) COMPLEX(kind=8), intent(out):: RHS( N ) DOUBLE PRECISION, intent(out):: W( N ) INTEGER K, I, J DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) DO 10 K = 1, N W(K) = DZERO RHS(K) = WRHS(K) 10 CONTINUE IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(I) = RHS(I) - ASPK(K) * LHS(J) W(I) = W(I) + abs(ASPK(K)) ENDDO ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(J) = RHS(J) - ASPK(K) * LHS(I) W(J) = W(J) + abs(ASPK(K)) ENDDO ENDIF ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(I) = RHS(I) - ASPK(K) * LHS(J) W(I) = W(I) + abs(ASPK(K)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K) * LHS(I) W(J) = W(J) + abs(ASPK(K)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_278 SUBROUTINE ZMUMPS_121( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) A_ELT(NA_ELT) COMPLEX(kind=8) LHS( N ), WRHS( N ), RHS( N ) DOUBLE PRECISION W(N) CALL ZMUMPS_257(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL ZMUMPS_119( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE ZMUMPS_121 SUBROUTINE ZMUMPS_119( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) A_ELT(NA_ELT) DOUBLE PRECISION TEMP DOUBLE PRECISION W(N) INTEGER K, I, J, IEL, SIZEI, IELPTR DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K = 1 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( K )) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K)) K = K + 1 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( K )) K = K + 1 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K )) K = K + 1 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_119 SUBROUTINE ZMUMPS_135(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION COLSCA(N) COMPLEX(kind=8) A_ELT(NA_ELT) DOUBLE PRECISION W(N) DOUBLE PRECISION TEMP, TEMP2 INTEGER K, I, J, IEL, SIZEI, IELPTR DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K = 1 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( K )) * TEMP2 K = K + 1 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( K )) * TEMP2 K = K + 1 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( K )*COLSCA(ELTVAR( IELPTR + J)) ) K = K + 1 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + I))) K = K + 1 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_135 SUBROUTINE ZMUMPS_122( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR, NA_ELT INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) COMPLEX(kind=8) A_ELT( NA_ELT ), 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_122 SUBROUTINE ZMUMPS_643( & 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_726(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_578(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_577( & 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_682(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_643 SUBROUTINE ZMUMPS_257( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) COMPLEX(kind=8) A_ELT( * ), X( N ), Y( N ) INTEGER IEL, I , J, K, SIZEI, IELPTR COMPLEX(kind=8) TEMP COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) Y = 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 K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & 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 ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE ZMUMPS_257 SUBROUTINE ZMUMPS_192 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE INTEGER N, NZ_loc INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) COMPLEX(kind=8) A_loc( NZ_loc ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE INTEGER I, J, K COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ENDDO ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(I) ENDDO END IF ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE ZMUMPS_192 SUBROUTINE ZMUMPS_256( N, NZ, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM ) INTEGER N, NZ, LDLT, MTYPE, MAXTRANS INTEGER IRN( NZ ), ICN( NZ ) INTEGER PERM( N ) COMPLEX(kind=8) ASPK( NZ ), X( N ), Y( N ) INTEGER K, I, J COMPLEX(kind=8) PX( N ) COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) Y = ZERO 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 IF (MTYPE .EQ. 1) THEN DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K) * PX(J) ENDDO ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K) * PX(I) ENDDO ENDIF ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K) * 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 RETURN END SUBROUTINE ZMUMPS_256 SUBROUTINE ZMUMPS_193 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE INTEGER N, NZ_loc INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) COMPLEX(kind=8) A_loc( NZ_loc ), X( N ) DOUBLE PRECISION Y_loc( N ) INTEGER LDLT, MTYPE INTEGER I, J, K DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ) ENDDO ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(I) ) ENDDO END IF ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE ZMUMPS_193 mumps-4.10.0.dfsg/src/mumps_static_mapping.F0000644000175300017530000047150511562233014021233 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE MUMPS_STATIC_MAPPING IMPLICIT NONE PRIVATE PUBLIC :: MUMPS_369, MUMPS_393, & MUMPS_427,MUMPS_494 integer,pointer,dimension(:,:),SAVE::cv_cand integer,pointer,dimension(:),SAVE::cv_par2_nodes integer,SAVE::cv_slavef,cv_nb_niv2,cv_lp,cv_mp #if defined(OLDSPLITTING) DOUBLE PRECISION,SAVE::cv_stack_peak integer,SAVE::cv_mem_strat #endif 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_369(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) nullify(thislayer) err_rep='INITPART1' call MUMPS_478(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_391(istat=ierr) if (ierr.ne.0) goto 99999 err_rep='CALCCOST' call MUMPS_417(ierr) if (ierr.ne.0) goto 99999 err_rep='ROOTLIST' call MUMPS_394(ierr) if (ierr.ne.0) goto 99999 err_rep='LAYERL0' call MUMPS_381(ierr) if (ierr.ne.0) goto 99999 if (ierr.ne.0) goto 99999 err_rep='INITPART2' call MUMPS_479(ierr) if (ierr.ne.0) goto 99999 err_rep='WORKMEM_' call MUMPS_408( & 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_396(ierr) if (ierr.ne.0) goto 99999 IF (cv_keep(38) .ne. 0 .and. cv_keep(60) .eq. 0 ) THEN call MUMPS_511(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_376(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_527 & (layernmb,thislayer,nmb_thislayer,ierr) endif if (ierr.ne.0) goto 99999 err_rep='ASSIGN_TYPES' call MUMPS_416(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_367(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_489(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_408( & 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_387(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_387(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_387(layernmb,thislayer, & nmb_thislayer,cv_equilib_flops,ierr) if (ierr.ne.0) goto 99999 else err_rep='MAP_LAYER' call MUMPS_387(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_377(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_431() endif ENDIF err_rep='SETUP_CAND' call MUMPS_397(ierr) if (ierr.ne.0) goto 99999 err_rep='ENCODE_PROC' call MUMPS_371(ierr) if (ierr.ne.0) goto 99999 err_rep='STORE_GLOB' call MUMPS_402(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_403(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_413( & 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)=1) write(*,*) 'k =',kk write(*,*) 'master_mem =',mem_master, & 'memory peak =',cv_stack_peak, & 'max mem authorized', & (dble(cv_mem_strat)/dble(100))*cv_stack_peak # endif if(mem_master.le. & (dble(cv_mem_strat)/dble(100))*cv_stack_peak) then k2 = kk exit endif #endif enddo k2 = max(k2, 1) k2 = min (k2, npiv) if(present(istat)) istat=0 return end subroutine MUMPS_526 subroutine MUMPS_529(inode,nfront,npiv,k, & ison,ifather,istat) implicit none integer, intent(in)::nfront,npiv integer, intent(in):: k integer inode integer,intent(out)::ison,ifather integer, intent(out)::istat integer i,lev,in,in_son,in_father,in_grandpa, & npiv_son,nfrontk,npivk,d1,f1,e1,dk,fk,next_father DOUBLE PRECISION:: ncostm,ncostw,ncostm_ison,ncostw_ison, & ncostm_ifather,ncostw_ifather character (len=48):: subname istat=-1 subname='SPLITNODE_INKPART' ison=-1 ifather=-1 ncostw=cv_ncostw(inode) ncostm=cv_ncostm(inode) nfrontk = nfront npivk = npiv npiv_son = npiv/k cv_keep(2)=max(cv_keep(2),nfront-npiv_son) d1 = inode f1 = d1 e1 = cv_frere(d1) do i=1,npiv_son-1 f1 = cv_fils(f1) enddo ison = d1 in_son = f1 next_father = cv_fils(in_son) call MUMPS_418(npiv_son,nfrontk, & ncostw_ison,ncostm_ison) cv_ncostw(ison)=ncostw_ison cv_ncostm(ison)=ncostm_ison if(associated(cv_tcostw)) cv_tcostw(ison) = cv_tcostw(inode) & -ncostw +cv_ncostw(ison) if(associated(cv_tcostm)) cv_tcostm(ison) = cv_tcostm(inode) & -ncostm +cv_ncostm(ison) do lev = 1,k-1 ifather = next_father in_father = ifather if(lev .eq. k-1) then do while (cv_fils(in_father).gt.0) in_father=cv_fils(in_father) end do else do i=1,npiv_son-1 in_father=cv_fils(in_father) enddo endif cv_frere(ison)=-ifather next_father = cv_fils(in_father) cv_fils(in_father)=-ison cv_nfsiz(ison)=nfrontk cv_nfsiz(ifather)=nfrontk-npiv_son cv_ne(ifather)=1 cv_keep(61)=cv_keep(61)+1 call MUMPS_418(npiv_son,nfrontk-npiv_son, & ncostw_ifather,ncostm_ifather) cv_ncostw(ifather)=ncostw_ifather cv_ncostm(ifather)=ncostm_ifather if(associated(cv_tcostw)) & cv_tcostw(ifather) = cv_tcostw(ison)+cv_ncostw(ifather) if(associated(cv_tcostm)) & cv_tcostm(ifather) = cv_tcostm(ison)+cv_ncostm(ifather) cv_total_split=cv_total_split+1 if(lev .gt. 1) then call MUMPS_437(inode,ison,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP4SPLIT error in ',subname istat = ierr return endif endif IF (cv_keep(79).EQ.0) THEN if( MUMPS_359(nfrontk-npiv_son,npiv_son) ) then cv_nodetype(ifather) = 2 else cv_nodetype(ifather) = 1 endif ELSE if (lev.EQ.1) then cv_nodetype(ison) = tsplit_beg cv_nodetype(ifather) = tsplit_mid else cv_nodetype(ifather) = tsplit_mid endif ENDIF nfrontk = nfrontk-npiv_son npivk = npivk - npiv_son ison = ifather in_son = in_father enddo dk = ifather fk = in_father IF (keep(79).EQ.0) THEN if( MUMPS_359(nfrontk,npivk) ) then cv_nodetype(dk) = 2 else cv_nodetype(dk) = 1 endif ELSE if (k.gt.1) then cv_nodetype(ifather) = tsplit_last endif ENDIF # if (check_mumps_static_mapping >= 3) write(6,*) ' Last (close to root) node in chain :', ifather #endif call MUMPS_418(npivk,nfrontk, & ncostw_ifather,ncostm_ifather) cv_ncostw(dk)=ncostw_ifather cv_ncostm(dk)=ncostm_ifather if(associated(cv_tcostw)) & cv_tcostw(dk) = cv_tcostw(ison)+cv_ncostw(dk) if(associated(cv_tcostm)) & cv_tcostm(dk) = cv_tcostm(ison)+cv_ncostm(dk) cv_fils(f1) = next_father cv_frere(dk) = e1 in = e1 do while (in.gt.0) in=cv_frere(in) end do in = -in do while(cv_fils(in).gt.0) in=cv_fils(in) end do in_grandpa = in if(cv_fils(in_grandpa).eq.-d1) then cv_fils(in_grandpa)=-dk else in=-cv_fils(in_grandpa) do while(cv_frere(in) .ne. d1) in=cv_frere(in) end do cv_frere(in) = dk end if ison = dk do lev=1,k do while (cv_fils(ison).gt.0) ison=cv_fils(ison) end do ison = -cv_fils(ison) enddo call MUMPS_437(inode,dk,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP4SPLIT error in ',subname istat = ierr return endif cv_nsteps = cv_nsteps + k-1 cv_ncostw(inode) = ncostw cv_ncostm(inode) = ncostm istat = 0 return end subroutine MUMPS_529 function MUMPS_811 (inode) implicit none integer, intent(in) :: inode logical :: MUMPS_811 if ( & (cv_nodetype(inode).EQ.2).OR. & (cv_nodetype(inode).EQ.tsplit_beg).OR. & (cv_nodetype(inode).EQ.tsplit_mid).OR. & (cv_nodetype(inode).EQ.tsplit_last) & ) then MUMPS_811 = .TRUE. else MUMPS_811 = .FALSE. endif return end function MUMPS_811 subroutine MUMPS_371(istat) implicit none integer, intent(out)::istat integer i,in,inode character (len=48):: subname istat=-1 subname='ENCODE_PROCNODE' do i=1,cv_nbsa inode=cv_ssarbr(i) cv_nodetype(inode)=0 in=cv_fils(inode) do while (in>0) in=cv_fils(in) end do in=-in do while(in.gt.0) call MUMPS_406(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 cv_nodetype(i)=3 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_371 subroutine MUMPS_372(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 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_459(cv_layerl0_end-oldl0end, & cv_layerl0_array(oldl0end+1:cv_layerl0_end), & cv_layerl0_sorted_costw(oldl0end+1:cv_layerl0_end)) call MUMPS_516( & 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)) endif istat=0 return end subroutine MUMPS_372 subroutine MUMPS_374(inode,map_strat,work,mem, & workload,memused,proc,istat,respect_prop) cDEC$ 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_481(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_374 subroutine MUMPS_376(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_376 subroutine MUMPS_377(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 (cv_nodetype(ifather).eq.tsplit_mid) then in = ifather cv_nodelayer (in) = -visited-1 cycle else if (cv_nodetype(ifather).eq.tsplit_last) then in = ifather cv_nodelayer (in) = current exit else write(6,*) ' Internal error 1 in MUMPS_HIGER_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 (cv_nodetype(ifather).eq.tsplit_mid) then in = ifather cv_nodelayer (in) = -visited-1 cycle else if (cv_nodetype(ifather).eq.tsplit_last) then in = ifather exit else write(6,*) ' Internal error 1 in MUMPS_HIGER_LAYER' 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_377 subroutine MUMPS_478(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 #if defined(OLDSPLITTING) cv_stack_peak = peak cv_mem_strat = max((300 / cv_slavef),1) #endif 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_478 subroutine MUMPS_479(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) #if !defined(treeload)&&!defined(treestat) 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 #endif 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 = cv_maxnsteps 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_479 function MUMPS_359(nfront,npiv) implicit none logical::MUMPS_359 integer,intent(in)::nfront,npiv MUMPS_359=.FALSE. if( (nfront - npiv > cv_keep(9)) & .and. ((npiv > cv_keep(4)).or.(.TRUE.)) & .and. (cv_icntl(40).eq.0) ) MUMPS_359=.TRUE. return end function MUMPS_359 subroutine MUMPS_381(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_415(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_413(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_372(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_382(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_477(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_415(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_415(map_strat, cv_layerl0_end, & cv_layerworkload,cv_layermemused, & cv_procnode,ierr) endif call MUMPS_386(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_381 subroutine MUMPS_382(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_382 subroutine MUMPS_477(istat) implicit none integer,intent(out)::istat integer i,pctr,pctr2,ierr,procindex(cv_size_ind_proc) istat = -1 pctr=cv_n pctr2=cv_mixed_strat_bound do i=1,cv_slavef call MUMPS_482(procindex,i,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr return 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_434(i,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(i)%ind_proc = procindex call MUMPS_433(i,pctr,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'PROPMAP signalled error to',subname istat = ierr return endif if((cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then call MUMPS_517(i,pctr2,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'MOD_PROPMAP signalled error to',subname istat = ierr return endif endif endif end do istat = 0 return end subroutine MUMPS_477 subroutine MUMPS_387(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 candid(cv_slavef) integer sorted_nmb(2*nmb_thislayer) DOUBLE PRECISION sorted_costw(2*nmb_thislayer), & sorted_costm(2*nmb_thislayer), & old_workload(cv_slavef),old_memused(cv_slavef) 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 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_811(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 return 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 return end if end do if (map_strat.eq.cv_equilib_flops) then call MUMPS_459(nmb,sorted_nmb(1:nmb), & sorted_costw(1:nmb),sorted_costm(1:nmb)) elseif(map_strat.eq.cv_equilib_mem) then call MUMPS_459(nmb,sorted_nmb(1:nmb), & sorted_costm(1:nmb),sorted_costw(1:nmb)) 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_398(map_strat, & cv_proc_workload,cv_proc_memused, & inode=inode,istat=ierr) else call MUMPS_398(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 return 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 return 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 return endif end if end do if(nmb_cand_needed.gt.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname return 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 return endif end if end do else inode=aux_int err_rep='SORTPROCS' if(use_propmap) then call MUMPS_398(map_strat, & cv_proc_workload,cv_proc_memused, & inode=inode,istat=ierr) else call MUMPS_398(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 return 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 return endif end if end do elseif (MUMPS_811(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 return 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 return 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 return endif end if end do if(nmb_cand_needed.gt.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname return 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 return 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 return end subroutine MUMPS_387 recursive subroutine MUMPS_385(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_385(in,procnmb,procnode) in=cv_frere(in) end do return end subroutine MUMPS_385 subroutine MUMPS_386(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_385(inode,procnmb,procnode) endif enddo return end subroutine MUMPS_386 subroutine MUMPS_389(map_strat,inode,istat) implicit none integer, intent(in)::map_strat integer,intent(out)::inode,istat character (len=48):: subname subname='MAX_TCOST_L0' inode=-1 istat=-1 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 if((map_strat.ne.cv_equilib_flops).and. & (map_strat.ne.cv_equilib_mem)) return inode=cv_layerl0_array(cv_layerl0_start) istat=0 return end subroutine MUMPS_389 subroutine MUMPS_431() 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_476(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_431 subroutine MUMPS_391(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_391 recursive subroutine MUMPS_517 & (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, & procs4son(cv_size_ind_proc),current,i 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 procs_inode(slavef) if (ctr.le.0) then istat = 0 return endif procs_inode=-1 istat= -1 if(cv_frere(inode).eq.cv_n+1) return subname='MOD_PROPMAP' if(.NOT.associated(cv_prop_map(inode)%ind_proc)) return nmb_procs_inode = 0 do j=1,cv_slavef if( MUMPS_481(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_493(j-1, & k69onid,ierr) else k69onid = j endif if(MUMPS_481(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 return endif 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 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 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 if(costs_sons.le.0D0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname return 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_481(in,k)) then nmb_propmap_strict=nmb_propmap_strict+1 call MUMPS_482(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_481(inode,k69onid)).AND. & (.NOT.MUMPS_480(procs4son,k69onid))) then if(k.ge.current2)then call MUMPS_482(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr return 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 return end if end if ierr=0 in1=in cv_prop_map(in1)%ind_proc=procs4son call MUMPS_517(in1,ctr-1,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname istat=ierr return endif in=cv_frere(in) end do istat = 0 return end subroutine MUMPS_517 recursive subroutine MUMPS_433(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,procs4son(cv_size_ind_proc),current,offset, & in_tmp,nfront,npiv,ncb, & keep48_loc,min_cand_needed 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_497, MUMPS_50 external MUMPS_497, MUMPS_50 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 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_481(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 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_493(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_481(inode,k69onid)) then call MUMPS_482(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr return 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_493(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_481(inode,k69onid)) then call MUMPS_482(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr return 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 return end if if(.NOT.associated(cv_prop_map(in)%ind_proc)) then call MUMPS_434(in,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 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_493(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_481(inode,k69onid)) then call MUMPS_482(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr return 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_493(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_481(inode,k69onid)) then call MUMPS_482(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr return 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 return 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_459(cv_slavef,id_son, & work_per_proc) 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_434(in,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(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_493(current-1,k69onid,ierr) else k69onid = current endif if(.NOT.MUMPS_481(inode,k69onid)) then current=current+1 else exit endif enddo call MUMPS_482(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_50 & (cv_slavef, keep48_loc,cv_keep8(21), & cv_keep(50), & nfront,ncb) 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_480(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_493(j-1,k69onid,ierr) else k69onid = j endif if(( MUMPS_481(inode,k69onid)).AND. & (.NOT.MUMPS_480(procs4son,k69onid))) then if(nb_free_procs.ge.current2)then call MUMPS_482(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr return 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_493(j-1,k69onid,ierr) else k69onid = j endif if(( MUMPS_481(inode,k69onid)).AND. & (.NOT.MUMPS_480(procs4son,k69onid))) then call MUMPS_482(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr return 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 return end if endif ierr=0 in1=in cv_prop_map(in1)%ind_proc = procs4son call MUMPS_433(in1,ctr-1,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname istat=ierr return endif in=cv_frere(in) end do istat = 0 return end subroutine MUMPS_433 subroutine MUMPS_434(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_434 subroutine MUMPS_435(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_435 subroutine MUMPS_436(ison,ifather,istat) implicit none integer,intent(in)::ison,ifather integer,intent(out)::istat character (len=48):: subname istat= -1 subname='PROPMAP4AMALG' call MUMPS_435(ison,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 istat = 0 return end subroutine MUMPS_436 subroutine MUMPS_437(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_434(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_437 subroutine MUMPS_394(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_459(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)) cv_costw_total=cv_costw_layer0 cv_costm_total=cv_costm_layer0 istat=0 return end subroutine MUMPS_394 subroutine MUMPS_396(istat) implicit none integer,intent(out)::istat character (len=48):: subname subname='SELECT_TYPE3' CALL MUMPS_712(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_396 subroutine MUMPS_397(istat) integer,intent(out):: istat integer :: i,dummy,layernmb,allocok integer :: montype, in, ifather, nbcand, & inode, k character (len=48):: subname istat=-1 subname='SETUP_CAND' cv_nb_niv2=0 do i=1,cv_n if(MUMPS_811(i)) cv_nb_niv2=cv_nb_niv2+1 end do cv_keep(56)=cv_nb_niv2 nullify(cv_par2_nodes,cv_cand) 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.4) then in = inode k = 1 do while (cv_frere(in).lt.0) ifather = -cv_frere(in) if ( (cv_nodetype(ifather).eq.tsplit_mid) .or. & (cv_nodetype(ifather).eq.tsplit_last) ) then if (nbcand.lt.2) then write(6,*) ' Internal WARNING 1 in SETUP_CAND', & ' nb split = ', k, 'greater than nbcand = ', & nbcand, ' see comment in code !' cv_par2_nodes(dummy+1) = ifather cv_procnode(ifather) = cv_procnode(in) cv_cand(dummy+1,:) = cv_cand(dummy,:) dummy = dummy + 1 write(6,*) ' Mapping property', & ' of procs in chain lost ' CALL MUMPS_ABORT() else cv_par2_nodes(dummy+1) = ifather cv_procnode(ifather) = cv_cand(dummy,1) + 1 cv_cand(dummy+1,1:nbcand-1+k-1) = & cv_cand(dummy,2:nbcand+k-1) cv_cand(dummy+1,nbcand-1+k) = cv_procnode(in)-1 cv_cand(dummy+1,cv_slavef+1)= nbcand-1 cv_cand(dummy+1,nbcand-1+k+1:cv_slavef) = cv_invalid nbcand = nbcand -1 dummy = dummy+1 endif else write(6,*) ' Internal error 2 in SETUP_CAND', & ' in, ifather =', in, ifather, & ' cv_nodetype(ifather) ', cv_nodetype(ifather) endif if (cv_nodetype(ifather).eq.tsplit_last) then exit endif in = ifather k = k + 1 end do 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 istat=0 return end subroutine MUMPS_397 subroutine MUMPS_398(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_481(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_398 subroutine MUMPS_402(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_402 subroutine MUMPS_403(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_435(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_403 recursive subroutine MUMPS_404(pos,istat) implicit none integer,intent(in)::pos integer, intent(out)::istat integer i,nfront,npiv,nextpos,ierr DOUBLE PRECISION costw,costm character (len=48):: subname istat=-1 subname='TREECOSTS' 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 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_418(npiv,nfront,costw,costm) cv_ncostw(pos)=costw cv_ncostm(pos)=costm 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_404(nextpos,ierr) if (ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Failure in recursive call to ',subname return end if costw=costw+cv_tcostw(nextpos) costm=costm+cv_tcostm(nextpos) nextpos=cv_frere(nextpos) end do endif cv_tcostw(pos) = costw cv_tcostm(pos) = costm istat = 0 end subroutine MUMPS_404 recursive subroutine MUMPS_406(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_406(in) in=cv_frere(in) enddo end subroutine MUMPS_406 subroutine MUMPS_408(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_408 subroutine MUMPS_476(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_476 end subroutine MUMPS_369 subroutine MUMPS_393(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_393' 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_393 subroutine MUMPS_427( & 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_430(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_429(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_492() 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_495(ierr) if(ierr .ne. 0 ) then return endif mem_distribmpi = mem_distribtmp call MUMPS_428(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_427 subroutine MUMPS_492() 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_492 subroutine MUMPS_428(ierr) implicit none external MUMPS_463 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_428' return end if do i=0,cv_slavef - 1 table_of_process(i) = i enddo call MUMPS_463(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_466(cv_slavef,mem_distribtmp(0), & table_of_process(0)) ierr = 0 return end subroutine MUMPS_428 subroutine MUMPS_429(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_429: & cannot find a master' ierr = 1 return end subroutine MUMPS_429 subroutine MUMPS_430(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_438 logical MUMPS_438 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_438(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_430 subroutine MUMPS_493(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_493 subroutine MUMPS_494() 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_494 subroutine MUMPS_495(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_495' 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_495' ierr = -13 return end if score = 0 ierr = 0 return end subroutine MUMPS_495 subroutine MUMPS_496(idproc,thenode) implicit none integer idproc,thenode thenode = mem_distribmpi(idproc) return end subroutine MUMPS_496 SUBROUTINE MUMPS_516(start1st,end1st,dim1, & start2nd,end2nd,dim2, & indx, & val) implicit none integer, intent(in):: start1st,end1st,dim1,start2nd,end2nd,dim2 integer, intent(inout):: indx(:) DOUBLE PRECISION, intent(inout):: val(:) integer::index(dim1+dim2) DOUBLE PRECISION ::dummy1(dim1+dim2) integer:: a,b,c 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) end SUBROUTINE MUMPS_516 SUBROUTINE MUMPS_459(dim,indx,val1,val2) implicit none integer, intent(in):: dim integer, intent(inout):: indx(:) DOUBLE PRECISION, intent(inout):: val1(:) DOUBLE PRECISION, intent(inout),optional:: val2(:) integer::index(dim),dummy1(dim) DOUBLE PRECISION ::dummy2(dim) integer, parameter :: ss = 35 integer:: a,b,c,i,k,l,r,s,stackl(ss),stackr(ss) 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 return end subroutine MUMPS_459 END MODULE MUMPS_STATIC_MAPPING SUBROUTINE MUMPS_712(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_712 mumps-4.10.0.dfsg/src/smumps_part5.F0000644000175300017530000102115711562233065017450 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE SMUMPS_26(id) USE SMUMPS_LOAD USE MUMPS_STATIC_MAPPING USE SMUMPS_STRUC_DEF USE TOOLS_COMMON USE SMUMPS_PARALLEL_ANALYSIS IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) TYPE(SMUMPS_STRUC), TARGET :: id INTEGER LIW, IKEEP, FILS, FRERE, PTRAR, NFSIZ INTEGER NE, NA INTEGER I, allocok INTEGER MAXIS1_CHECK 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 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 INTEGER(8) K13TMP8, K14TMP8 REAL PEAK INTEGER, ALLOCATABLE, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR 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_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 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 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 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 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (PROK) WRITE( MP, 220 ) IF (PROKG.AND.(MPG .NE. MP)) WRITE( MPG, 220 ) id%VERSION_NUMBER 220 FORMAT( /' SMUMPS ',A ) 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 ) CALL SMUMPS_647(id) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN 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 ) ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN CALL MPI_ALLREDUCE( id%NZ_loc, id%NZ, 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR ) ELSE CALL MPI_BCAST( id%NZ, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) END IF ELSE CALL MPI_BCAST( id%NA_ELT, 1, MPI_INTEGER, 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_427( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO) CALL SMUMPS_658(id) IF (KEEP(244) .EQ. 1) THEN IF ( KEEP(54) .eq. 3 ) THEN CALL SMUMPS_664(id) END IF IF ( id%MYID .eq. MASTER ) THEN 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 IF (.not.associated(id%A)) THEN IF (KEEP(23).GT.2) KEEP(23) = 1 ENDIF CALL SMUMPS_203(id%N, id%NZ, KEEP(23), id%IS1(1), id, & ICNTL(1), INFO(1)) IF (INFO(1) .LT. 0) THEN KEEP(23) = 0 GOTO 10 END IF END IF IF (KEEP(55) .EQ. 0) THEN IF ( KEEP(256) .EQ. 1 ) THEN LIW = 2 * id%NZ + 3 * id%N + 2 ELSE LIW = 2 * id%NZ + 3 * id%N + 2 ENDIF IF (LIW.LT.3*id%N) LIW = 3*id%N ELSE #if defined(metis) || defined(parmetis) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN LIW = id%N + id%N + 1 ELSE LIW = id%N + id%N + id%N+3 + id%N+1 ENDIF ENDIF IF (LIW.LT.3*id%N) LIW = 3*id%N 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 PTRAR = FRERE + id%N IF (KEEP(55) .EQ. 0) THEN NFSIZ = PTRAR + 4 * id%N MAXIS1_CHECK = NFSIZ + id%N - 1 ELSE NFSIZ = PTRAR + 2 * (NELT + 1) MAXIS1_CHECK = NFSIZ + id%N -1 ENDIF IF ( id%MAXIS1 .LT. MAXIS1_CHECK ) THEN IF (LP.GE.0) THEN WRITE(LP,*) '***********************************' WRITE(LP,*) 'MAXIS1 and MAXIS1_CHECK are different !!' WRITE(LP,*) 'MAXIS1, MAXIS1_CHECK=',id%MAXIS1, & MAXIS1_CHECK WRITE(LP,*) 'This might cause problems ...' WRITE(LP,*) '***********************************' ENDIF END IF IF ( KEEP(256) .EQ. 1 ) THEN DO I = 1, id%N id%IS1( IKEEP + I - 1 ) = id%PERM_IN( I ) END DO END IF INFOG(1) = 0 INFOG(2) = 0 INFOG(8) = -1 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 IF (KEEP(55) .EQ. 0) THEN CALL SMUMPS_195(id%N, id%NZ, id%IRN(1), id%JCN(1), & LIW, id%IS1(IKEEP), & id%IS1(PTRAR), 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 KEEP(23) = -KEEP(23) IF (.NOT. associated(id%A)) KEEP(23) = 1 GOTO 1234 ENDIF INFOG(7) = KEEP(256) ELSE allocate( IWtemp ( 3*id%N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*id%N IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IWtemp' END IF GOTO 10 ENDIF allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL SMUMPS_128(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW, & id%IS1(IKEEP), & IWtemp(1), 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%ELTPROC(1), id%NSLAVES, & XNODEL(1), NODEL(1)) DEALLOCATE(IWtemp) INFOG(7)=KEEP(256) ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN deallocate( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) ENDIF INFO(1)=INFOG(1) INFO(2)=INFOG(2) KEEP(28) = INFOG(6) IF ( INFO(1) .LT. 0 ) THEN GO TO 10 ENDIF ENDIF ELSE IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N FILS = IKEEP + 3 * id%N FRERE = FILS + id%N PTRAR = FRERE + id%N NFSIZ = PTRAR + 4 * id%N IF(id%MYID .EQ. MASTER) THEN WORK1PTR => id%IS1(IKEEP : IKEEP + 3*id%N-1) WORK2PTR => id%IS1(PTRAR : PTRAR + 4*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) ELSE ALLOCATE(WORK1PTR(3*id%N)) ALLOCATE(WORK2PTR(4*id%N)) END IF CALL SMUMPS_715(id, & WORK1PTR, & WORK2PTR, & NFSIZPTR, & FILSPTR, & FREREPTR) IF(id%MYID .EQ. 0) THEN NULLIFY(WORK1PTR, WORK2PTR, NFSIZPTR) NULLIFY(FILSPTR, FREREPTR) ELSE DEALLOCATE(WORK1PTR, WORK2PTR) END IF KEEP(28) = INFOG(6) END IF 10 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN IF(id%MYID .EQ. MASTER) THEN CALL MUMPS_633(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL SMUMPS_348(id%N, id%IS1(FILS), id%IS1(FRERE), & id%IS1(IKEEP+2*id%N), id%IS1(IKEEP+id%N)) IF (id%NSLAVES .EQ. 1) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN id%KEEP(20)=0 id%KEEP(38)=0 ENDIF id%KEEP(56)=0 id%PROCNODE = 0 IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN CALL SMUMPS_564(id%KEEP(38), id%PROCNODE(1), & 1+2*id%NSLAVES, id%IS1(FILS),id%N) ENDIF ELSE PEAK = real(id%INFOG(5))*real(id%INFOG(5)) + & real(id%KEEP(2))*real(id%KEEP(2)) SSARBR => id%IS1(IKEEP:IKEEP+id%N-1) CALL SMUMPS_537(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 in MUMPS_369' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL SMUMPS_348(id%N, id%IS1(FILS), & id%IS1(FRERE), id%IS1(IKEEP+2*id%N), & id%IS1(IKEEP+id%N)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ) ELSE LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_733(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_733(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_733(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN IF(id%MYID .EQ. MASTER) THEN CALL SMUMPS_153( & 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 id%PTRAR(id%NELT+I+1)=id%ELTPTR(I) ENDDO deallocate(XNODEL) deallocate(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER, & 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 IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN CALL SMUMPS_120(id%N, NELT, id%ELTPROC(1),id%NSLAVES, & id%PROCNODE(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LP .GT. 0 ) 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_330(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_26", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_393 & (PAR2_NODES,id%CANDIDATES,IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF CALL MUMPS_494() 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF 12 CONTINUE KEEP(84) = ICNTL(27) END IF CALL MUMPS_276( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) RETURN CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MUMPS_749( id%KEEP8(21), MASTER, & id%MYID, id%COMM, IERR) CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MUMPS_733(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_733(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_733(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_733(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_733(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_733(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_733(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_733(id%SYM_PERM, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 IF (KEEP(55) .EQ. 0) THEN LPTRAR = id%N+id%N CALL MUMPS_733(id%PTRAR, LPTRAR, id%INFO, LP, FORCE=.TRUE., & STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF ( associated( id%UNS_PERM ) ) deallocate(id%UNS_PERM) IF ( id%MYID == MASTER .AND. id%KEEP(23) .NE. 0 ) THEN allocate(id%UNS_PERM(id%N),stat=allocok) IF ( allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = id%N IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'id%UNS_PERM' END IF GOTO 94 ENDIF DO I=1,id%N id%UNS_PERM(I) = id%IS1(I) END DO ENDIF 94 CONTINUE CALL MUMPS_276( 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 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_733(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 id%NA(1) = NBLEAF id%NA(2) = NBROOT 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF IF ( id%MYID .EQ. MASTER ) THEN ISTEP = 0 DO I = 1, id%N IF ( id%IS1(FRERE+I-1) .ne. id%N + 1 ) THEN 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 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_26' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in SMUMPS_26' CALL MUMPS_ABORT() ENDIF 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 DO I = 1, id%N IF ( id%STEP(I) .LE. 0) CYCLE IF (id%IS1(FRERE+I-1) .eq. 0) THEN id%DAD_STEPS(id%STEP(I)) = 0 ENDIF IFS = id%IS1(FILS+I-1) DO WHILE ( IFS .GT. 0 ) IFS= id%IS1(FILS + IFS -1) END DO IFS = -IFS DO WHILE (IFS.GT.0) id%DAD_STEPS(id%STEP(IFS)) = I IFS = id%IS1(FRERE+IFS-1) ENDDO END DO deallocate(id%PROCNODE) NULLIFY(id%PROCNODE) deallocate(id%IS1) NULLIFY(id%IS1) CALL SMUMPS_363(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(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 SIZE_TEMP_MEM = id%NBSA ELSE 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 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 ( LP .GT. 0 ) 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_364(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 CALL SMUMPS_181(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) ) ENDIF 80 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN 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(55) .EQ. 0) THEN CALL SMUMPS_746(id, id%PTRAR(1)) IF(id%MYID .EQ. MASTER) THEN IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN DEALLOCATE( id%IRN ) DEALLOCATE( id%JCN ) END IF END IF ENDIF 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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 ( LP .GT. 0 ) 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_276( 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 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 ( LP .GT. 0 ) 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 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(id%STEP(INN)) = INIV2 END DO CALL SMUMPS_649( id%NSLAVES, & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF #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 ( LP .GT. 0 ) 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_275( & id%PROCNODE_STEPS(id%STEP(PAR2_NODES(INIV2))), & id%NSLAVES) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO #endif 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 allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LP .GT. 0 ) 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 IF (NB_NIV2.GT.0) deallocate (PAR2_NODES) 321 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN 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 PTRAR = FRERE + id%N IF (KEEP(55) .EQ. 0) THEN IF ( id%MYID.EQ.MASTER ) THEN NFSIZ = PTRAR + 4 * id%N ELSE NFSIZ = PTRAR + 2 * id%N ENDIF ELSE NFSIZ = PTRAR + 2 * (NELT + 1) END IF IF ( KEEP(38) .NE. 0 ) THEN CALL SMUMPS_164( 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 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 ( LP > 0 .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 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF ( I_AM_SLAVE ) THEN IF (KEEP(55) .EQ. 0) THEN CALL SMUMPS_24( 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_25( 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 IF ( I_AM_SLAVE ) THEN 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 id%SCHUR_MLOC=LOCAL_M id%SCHUR_NLOC=LOCAL_N 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_246( id%MYID_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), & KEEP8(14), & 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), & id%I_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%MAX_SURF_MASTER = KEEP8(15) KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 2* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) INFO( 19 ) = KEEP(225) + 2* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /100_8 +1_8) CALL MUMPS_736 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) 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 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 ) KEEP(44) = max(KEEP(44), MIN_BUF_SIZE) KEEP(43) = max(KEEP(43), MIN_BUF_SIZE) IF ( MP .GT. 0 ) THEN WRITE(MP,'(A,I10) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I10) ') & ' INFO(3), est. real space to store factors :', & KEEP8(11) WRITE(MP,'(A,I10) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I10) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I10) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I10) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I10) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF ELSE 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 CALL MUMPS_736( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_736( 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_646( KEEP8(11), KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735( KEEP8(111), INFOG(3) ) CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_REAL, MPI_SUM, & id%COMM, IERR) CALL MUMPS_735( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_735( KEEP8(13), INFO(8) ) CALL MUMPS_735( KEEP8(17), INFO(20) ) CALL MUMPS_735( KEEP8(9), INFO(24) ) INFOG( 4 ) = KEEP( 126 ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_735( KEEP8(109), INFOG(20) ) CALL SMUMPS_100(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1)) OOC_STAT = KEEP(201) IF (KEEP(201) .NE. -1) OOC_STAT=0 PERLU_ON = .FALSE. CALL SMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(2) = TOTAL_BYTES PERLU_ON = .TRUE. CALL SMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' Estimated space in MBYTES for IC factorization :', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES CALL MUMPS_243( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of proc needing largest memory in IC facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Estimated corresponding MBYTES for IC facto :', & id%INFOG(16) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,(id%INFOG(17)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (IC) :' & ,id%INFOG(17)/id%NSLAVES END IF WRITE(MPG,'(A,I10) ') & ' ** TOTAL space in MBYTES for IC factorization :' & ,id%INFOG(17) END IF 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. CALL SMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) KEEP8(3) = TOTAL_BYTES PERLU_ON = .TRUE. CALL SMUMPS_214( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STAT, PERLU_ON, TOTAL_BYTES) id%INFO(17) = TOTAL_MBYTES CALL MUMPS_243( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of proc needing largest memory for OOC facto :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Estimated corresponding MBYTES for OOC facto :', & id%INFOG(26) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,(id%INFOG(27)-id%INFO(15))/id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Estimated avg. MBYTES per work. proc at facto (OOC) :' & ,id%INFOG(27)/id%NSLAVES END IF WRITE(MPG,'(A,I10) ') & ' ** TOTAL space in MBYTES for OOC factorization :' & ,id%INFOG(27) END IF IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) & deallocate( id%MAPPING) allocate( id%MAPPING(id%NZ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NZ IF ( LP .GT. 0 ) 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 ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF CALL SMUMPS_83( & id%N, id%MAPPING(1), & id%NZ, 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_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) RETURN RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 150 FORMAT( & /' ** FAILURE DURING SMUMPS_26, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE SMUMPS_26 SUBROUTINE SMUMPS_537(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_369(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & ) RETURN END SUBROUTINE SMUMPS_537 SUBROUTINE SMUMPS_564(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_564 SUBROUTINE SMUMPS_647(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF (id%MYID.eq.MASTER) THEN id%KEEP(256) = id%ICNTL(7) id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 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 id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN 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 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 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 WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' id%KEEP(60)=0 END IF 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 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 IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF id%KEEP(244) = id%ICNTL(28) id%KEEP(245) = id%ICNTL(29) #if ! defined(parmetis) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP,'("ParMETIS not available.")') WRITE(LP,'("Aborting.")') RETURN END IF END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP,'("PT-SCOTCH not available.")') WRITE(LP,'("Aborting.")') RETURN END IF END IF #endif IF((id%KEEP(244) .GT. 2) .OR. & (id%KEEP(244) .LT. 0)) id%KEEP(244)=0 IF(id%KEEP(244) .EQ. 0) THEN id%KEEP(244) = 1 ELSE IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') RETURN END IF 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 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) = 0 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 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 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 IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF 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 id%INFO(1) = -22 id%INFO(2) = 8 RETURN IF (MPG.GT.0) 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 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 id%KEEP(23) = id%ICNTL(6) IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 7 IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not compatible with LLT factorization' END IF ENDIF id%KEEP(95) = 1 END IF IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (MPG.GT.0) 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 (MPG.GT.0) 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. MPG.GT.0) 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 (MPG.GT.0) 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 IF (MPG.GT.0) 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 (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed for element matrix' END IF id%KEEP(23) = 0 ENDIF IF (MPG.GT.0 .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 IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') RETURN END IF END IF IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF IF (id%ICNTL(39).NE.1 .and. id%ICNTL(39).NE.2) THEN id%KEEP(106)=1 ELSE id%KEEP(106)=id%ICNTL(39) ENDIF IF(id%KEEP(50) .EQ. 2) THEN IF( .NOT. associated(id%A) ) THEN 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 IF (PROK) WRITE(MP,*) & 'WARNING: SMUMPS_203 constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) 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 IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE 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 id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF id%KEEP(53)=0 IF(id%KEEP(86).EQ.1)THEN 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 END IF RETURN END SUBROUTINE SMUMPS_647 SUBROUTINE SMUMPS_664(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE(SMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER :: MASTER, IERR, INDX, NRECV INTEGER :: STATUS( MPI_STATUS_SIZE ) INTEGER :: LP, MP, MPG, I LOGICAL :: PROK, PROKG PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN id%NZ_loc = 0 END IF IF ( id%MYID .eq. MASTER ) THEN allocate( REQPTR( id%NPROCS, 3 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 3 * id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'REQPTR' END IF GOTO 13 END IF allocate( id%IRN( id%NZ ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NZ IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'IRN' END IF GOTO 13 END IF allocate( id%JCN( id%NZ ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NZ IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'JCN' END IF GOTO 13 END IF END IF 13 CONTINUE CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN IF ( id%MYID .EQ. MASTER ) THEN DO I = 1, id%NPROCS - 1 CALL MPI_RECV( REQPTR( I+1, 1 ), 1, & MPI_INTEGER, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) END DO IF ( id%KEEP(46) .eq. 0 ) THEN REQPTR( 1, 1 ) = 1 ELSE REQPTR( 1, 1 ) = id%NZ_loc + 1 END IF DO I = 2, id%NPROCS REQPTR( I, 1 ) = REQPTR( I, 1 ) + REQPTR( I-1, 1 ) END DO ELSE CALL MPI_SEND( id%NZ_loc, 1, MPI_INTEGER, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN NRECV = 0 DO I = 1, id%NPROCS - 1 IF ( REQPTR( I + 1, 1 ) - REQPTR( I, 1 ) .NE. 0 ) THEN NRECV = NRECV + 2 CALL MPI_IRECV( id%IRN( REQPTR( I, 1 ) ), & REQPTR( I + 1, 1 ) - REQPTR( I, 1 ), & MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I, 2), IERR ) CALL MPI_IRECV( id%JCN( REQPTR( I, 1 ) ), & REQPTR( I + 1, 1 ) - REQPTR( I, 1 ), & MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I, 3), IERR ) ELSE REQPTR(I, 2) = MPI_REQUEST_NULL REQPTR(I, 3) = MPI_REQUEST_NULL END IF END DO ELSE IF ( id%NZ_loc .NE. 0 ) THEN CALL MPI_SEND( id%IRN_loc(1), id%NZ_loc, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(1), id%NZ_loc, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END IF END IF IF ( id%MYID .eq. MASTER ) THEN IF ( id%NZ_loc .NE. 0 ) THEN DO I=1,id%NZ_loc id%IRN(I) = id%IRN_loc(I) id%JCN(I) = id%JCN_loc(I) ENDDO END IF REQPTR( id%NPROCS, 2 ) = MPI_REQUEST_NULL REQPTR( id%NPROCS, 3 ) = MPI_REQUEST_NULL DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * id%NPROCS, REQPTR( 1, 2 ), INDX, STATUS, IERR ) END DO deallocate( REQPTR ) END IF RETURN 150 FORMAT( &/' ** FAILURE DURING SMUMPS_664, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE SMUMPS_664 SUBROUTINE SMUMPS_658(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(SMUMPS_STRUC) :: id 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) IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (id%MYID.EQ.MASTER .AND. .NOT. IS_DISTRIBUTED) THEN IF (id%WRITE_PROBLEM(1:20) .NE. "NAME_NOT_INITIALIZED")THEN OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL SMUMPS_166( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL ) CLOSE(IUNIT) ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN 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) IF (MM_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(MM_IDSTR,'(I7)') id%MYID_NODES OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(MM_IDSTR))) CALL SMUMPS_166(id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL ) CLOSE(IUNIT) ENDIF ENDIF 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_179(IUNIT, id) CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE SMUMPS_658 SUBROUTINE SMUMPS_166 & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL ) USE SMUMPS_STRUC_DEF IMPLICIT NONE LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL INTEGER, intent(in) :: IUNIT TYPE(SMUMPS_STRUC), intent(in) :: id CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER :: I IF (IS_ELEMENTAL) THEN RETURN ENDIF IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED) THEN IF (associated(id%A)) 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, id%NZ IF (associated(id%A)) THEN DO I=1,id%NZ IF (id%KEEP(50).NE.0 .AND. id%IRN(I).LT.id%JCN(I)) THEN WRITE(IUNIT,*) id%JCN(I), id%IRN(I), id%A(I) ELSE WRITE(IUNIT,*) id%IRN(I), id%JCN(I), id%A(I) ENDIF ENDDO ELSE DO I=1,id%NZ IF (id%KEEP(50).NE.0 .AND. id%IRN(I).LT.id%JCN(I)) THEN WRITE(IUNIT,*) id%JCN(I), id%IRN(I) ELSE WRITE(IUNIT,*) id%IRN(I), id%JCN(I) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN 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, id%NZ_loc IF (associated(id%A_loc)) THEN DO I=1,id%NZ_loc IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I), & id%A_loc(I) ELSE WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I), & id%A_loc(I) ENDIF ENDDO ELSE DO I=1,id%NZ_loc IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I).LT.id%JCN_loc(I)) THEN WRITE(IUNIT,*) id%JCN_loc(I), id%IRN_loc(I) ELSE WRITE(IUNIT,*) id%IRN_loc(I), id%JCN_loc(I) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_166 SUBROUTINE SMUMPS_179(IUNIT, id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT CHARACTER (LEN=8) :: ARITH INTEGER :: I, J, K, LD_RHS 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_179 SUBROUTINE SMUMPS_649( NSLAVES, NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND 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 RETURN END SUBROUTINE SMUMPS_649 SUBROUTINE SMUMPS_251(N,IW,LIW,A,LA, & NSTK_STEPS, NBPROCFILS,IFLAG,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, IERROR,IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, & LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST_S, 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) USE SMUMPS_LOAD USE SMUMPS_OOC IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER N,IFLAG,NTOTPV,MAXFRT,LIW, LPTRAR, NMAXNPIV, & IERROR, 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 PTRARW(LPTRAR), PTRAIW(LPTRAR), ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST_S(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 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 ) INTEGER INTARR( max(1,KEEP(14)) ) REAL DBLARR( max(1,KEEP(13)) ) LOGICAL IS_ISOLATED_NODE INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ), IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBRTOT, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS 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_330, MUMPS_275 INTEGER MUMPS_330, MUMPS_275 LOGICAL MUMPS_167,MUMPS_283 EXTERNAL MUMPS_167,MUMPS_283 LOGICAL SMUMPS_508 EXTERNAL SMUMPS_508, SMUMPS_509 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 ASS_IRECV = MPI_REQUEST_NULL ITLOC(1:N+KEEP(253)) =0 PTRIST (1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRAST(1:KEEP(28))=0_8 PTRFAC(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_22( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, & IFLAG, IERROR & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 NBPROCFILS(1:KEEP(28)) = 0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL SMUMPS_284( & 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, IFLAG, KEEP,KEEP8, IERROR ) ENDIF IF ( IFLAG .LT. 0 ) GOTO 635 END IF 20 CONTINUE NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( & 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_STEPS, & COMP, IFLAG, & IERROR, COMM_NODES, & NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED ) CALL SMUMPS_467(COMM_LOAD, KEEP) IF (MESSAGE_RECEIVED) THEN IF ( IFLAG .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. SMUMPS_508( IPOOL, LPOOL) )THEN CALL SMUMPS_509( 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_500( & 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_501( & 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_512(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_242(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_330(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_144( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, & NPVW, & COMM_NODES, MYID_NODES, 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_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) IF ( IFLAG .LT. 0 ) GOTO 640 ELSE CALL SMUMPS_141( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, & NPVW, & COMM_NODES, MYID_NODES, 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_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) IF ( IFLAG .LT. 0 ) GOTO 640 IF ( IW( PTLUST_S(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_176( 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_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & IFLAG, IERROR, COMM_NODES, & NBPROCFILS, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL SMUMPS_36( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ELSE JOBASS = 0 CALL SMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF IF ( IFLAG .LT. 0 ) GOTO 640 IF ((NBPROCFILS(STEP(INODE)).GT.0).OR.(SON_LEVEL2)) GOTO 20 ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL SMUMPS_253(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & IFLAG, IERROR, & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & ) ELSE CALL SMUMPS_37( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, IFLAG, IERROR, & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, & root, OPASSW, OPELIW, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,INTARR,DBLARR, & NBPROCFILS, PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0)) END IF IF (IFLAG.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_251", POSELT CALL MUMPS_ABORT() ENDIF CALL SMUMPS_87 & ( IW(PTLUST_S(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST_S(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_143( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & IFLAG, UU, NOFFW, NPVW, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL SMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL SMUMPS_140( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & IFLAG, UU, NOFFW, NPVW, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS) IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL SMUMPS_252(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & IFLAG,IERROR,ND, & FILS,FRERE,DAD,MAXFRW,root,OPASSW, OPELIW, & PTRIST,PTLUST_S,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8, INTARR, DBLARR, & 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 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_330(PROCNODE_STEPS(STEP(FPERE)),SLAVEF) ELSE TYPEF = -9999 END IF CALL SMUMPS_254( 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,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 ) IF (IFLAG.LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in SMUMPS_251: ', & ' 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_681(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL SMUMPS_580(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in SMUMPS_251: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in SMUMPS_251: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL SMUMPS_242( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_275(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_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF)) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL SMUMPS_507(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_137( 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_190(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE CALL SMUMPS_44( MYID_NODES, SLAVEF, COMM_NODES ) 640 CONTINUE CALL SMUMPS_255( INFO(1), & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL SMUMPS_180( INFO(1), & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, MP) 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_275( & 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_S(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_731(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before SMUMPS_146', LBUFRX CALL MUMPS_ABORT() ENDIF IS_BUFRX_ALLOCATED = .FALSE. ENDIF CALL SMUMPS_146( MYID_NODES, & root, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST_S, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_275(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_729(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 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL SMUMPS_688 & ( 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_576(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in SMUMPS_576' CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 IF (KEEP(252).NE.0) THEN CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLU) ELSE CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLU) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLU) 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_731(LRHS_CNTR_MASTER_ROOT,INFO(2)) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before SMUMPS_146', & 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_156( 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_S(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 CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-NFRONT8*NFRONT8,KEEP,KEEP8,LRLU) ENDIF ENDIF END IF END IF END IF IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_275(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_251 SUBROUTINE SMUMPS_87( 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' CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE SMUMPS_87 SUBROUTINE SMUMPS_136( id ) USE SMUMPS_OOC USE SMUMPS_STRUC_DEF USE SMUMPS_COMM_BUFFER IMPLICIT NONE include 'mpif.h' TYPE( SMUMPS_STRUC ) :: id LOGICAL I_AM_SLAVE INTEGER IERR, MASTER PARAMETER ( MASTER = 0 ) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL SMUMPS_587(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_276(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 CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF NULLIFY(id%SCHUR_CINTERFACE) 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%POIDS)) THEN DEALLOCATE(id%POIDS) NULLIFY(id%POIDS) ENDIF 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 IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF 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) ENDIF IF (associated(id%POSINRHSCOMP)) THEN DEALLOCATE(id%POSINRHSCOMP) NULLIFY(id%POSINRHSCOMP) ENDIF 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 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_636(id) IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF 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 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%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%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 IF (id%KEEP8(24).EQ.0_8) THEN IF (associated(id%S)) DEALLOCATE(id%S) ELSE ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN CALL SMUMPS_57( IERR ) CALL SMUMPS_59( IERR ) END IF IF ( associated( id%BUFR ) ) DEALLOCATE( id%BUFR ) NULLIFY( id%BUFR ) RETURN END SUBROUTINE SMUMPS_136 SUBROUTINE SMUMPS_150(MYID,COMM,S,MAXS,MAXS_BYTES) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) INTEGER COMM, MYID, MAXS, MAXS_BYTES INTEGER S( MAXS ) INTEGER MSGTAG, MSGSOU, MSGLEN LOGICAL FLAG FLAG = .TRUE. DO WHILE ( FLAG ) CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) IF (FLAG) THEN MSGTAG=STATUS(MPI_TAG) MSGSOU=STATUS(MPI_SOURCE) CALL MPI_GET_COUNT(STATUS,MPI_PACKED,MSGLEN,IERR) IF (MSGLEN <= MAXS_BYTES) THEN CALL MPI_RECV(S(1),MAXS_BYTES,MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR) ELSE EXIT ENDIF END IF END DO CALL MPI_BARRIER( COMM, IERR ) RETURN END SUBROUTINE SMUMPS_150 SUBROUTINE SMUMPS_254(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, & 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 ) USE SMUMPS_COMM_BUFFER 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) 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) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(max(1,KEEP(13))) INTEGER INTARR(max(1,KEEP(14))) 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 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_275 EXTERNAL MUMPS_275 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_167, &MUMPS_170 EXTERNAL MUMPS_167, MUMPS_170 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_167(PROCNODE_STEPS(STEP(INODE)),SLAVEF) SSARBR_ROOT = MUMPS_170 & (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(*,*) "Error 1 in G" 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_511( 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_190(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_511( 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_190(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_511(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (SSARBR_ROOT) THEN CALL SMUMPS_190(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL SMUMPS_190(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_80( & 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, .FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_275(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_273( 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, & COMM, COMM_LOAD, FILS, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL SMUMPS_76( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE.) 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_275(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_275( 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_66( 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, IERR ) ELSE IF ( (TYPE.EQ.2).AND.(KEEP(48).NE.0)) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL SMUMPS_70( 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_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_254", 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_254", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_275(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_22( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,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_275(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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_652( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, COMPRESSCB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL SMUMPS_705( 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_651( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED ) 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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_93(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1) CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE SMUMPS_254 SUBROUTINE SMUMPS_142( id) USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD USE SMUMPS_OOC USE SMUMPS_STRUC_DEF IMPLICIT NONE #ifndef SUN_ INTERFACE SUBROUTINE SMUMPS_27(id, ANORMINF, LSCAL) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id REAL, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL END SUBROUTINE SMUMPS_27 END INTERFACE #endif TYPE(SMUMPS_STRUC), TARGET :: id INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INCLUDE 'mumps_headers.h' INTEGER NSEND, NSEND_TOT, LDPTRAR, NELT INTEGER NLOCAL, NLOCAL_TOT, KEEP13_SAVE, ITMP INTEGER(8) K67 INTEGER(8) ITMP8 INTEGER MUMPS_275 EXTERNAL MUMPS_275 INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL INTEGER SMUMPS_LBUF, SMUMPS_LBUFR_BYTES, SMUMPS_LBUF_INT INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, NSTEPS, K28, LPOOL, LIW INTEGER IRANK, ID_ROOT INTEGER KKKK, NZ_locMAX 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 REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233 INTEGER COLOUR, COMM_FOR_SCALING INTEGER LIWK, LWK, LWK_REAL LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED 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, 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 INTEGER, POINTER :: JOB, NZ REAL,DIMENSION(:),POINTER::RINFO, RINFOG REAL,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER::INFO, 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(8),DIMENSION(:),POINTER::KEEP8 INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL SMUMPS_505 INTEGER SMUMPS_505 INTEGER(8) TOTAL_BYTES INTEGER(8) :: I8TMP INTEGER numroc EXTERNAL numroc REAL, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED JOB=>id%JOB NZ=>id%NZ RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFO=>id%INFO INFOG=>id%INFOG KEEP=>id%KEEP KEEP8=>id%KEEP8 ICNTL=>id%ICNTL IF (id%NZ_loc .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 ) NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. IF (KEEP8(24).GT.0_8) THEN NULLIFY(id%S) ENDIF WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN KEEP8(24) = int(id%LWK_USER,8) ELSE KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE KEEP8(24) = 0_8 ENDIF KEEP13_SAVE = KEEP(13) id%DKEEP(4)=-1.0E0 id%DKEEP(5)=-1.0E0 MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LP = ICNTL( 1 ) PROK = ( MP .GT. 0 ) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) 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. 0 ) 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 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN KEEP(201)=id%ICNTL(22) IF (KEEP(201) .NE. 0) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF 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(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 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 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 IF ( KEEP(50) .eq. 1 ) THEN IF (id%CNTL(1) .ne. ZERO ) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') &' ** Warning : SPD solver called, resetting CNTL(1) to 0.0E0' END IF END IF id%CNTL(1) = ZERO END IF IF (KEEP(219).NE.0) THEN CALL SMUMPS_617(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN INFO(1) = -13 INFO(2) = max(KEEP(108),1) END IF ENDIF IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN 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 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: sparse RHS incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 IF ( PROKG ) THEN WRITE( MPG, 172 ) id%NSLAVES, id%ICNTL(22), & KEEP8(111), KEEP(126), KEEP(127), KEEP(28) IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) ENDIF IF (KEEP(201).LE.0) THEN KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF 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 KEEP(260) = 1 id%DKEEP(6) = 1.0E0 ENDIF 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 IF ( id%MYID.EQ.MASTER ) THEN ENDIF IF (KEEP(52) .EQ. 7) THEN K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_REAL,MASTER, & id%COMM,IERR) IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN 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 INFO(1)=-13 INFO(2)=LIWK+M+N+4* (id%NPROCS) ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 BUJOB = 1 LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL)) CALL SMUMPS_693( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%NZ_loc, & 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 INFO(1)=-13 INFO(2)=LIWK ENDIF ENDIF LWK_REAL = BURESZ DEALLOCATE(WK_REAL) ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=LWK_REAL ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 530 BUJOB = 2 CALL SMUMPS_693( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%NZ_loc, & 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 DEALLOCATE(IWK, WK_REAL,BURP,BUCP,BURS, BUCS) ELSE IF ( KEEP(54) .EQ. 0 ) THEN IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN 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 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 INFO(1)=-13 INFO(2)=1 ENDIF IF (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_693( & id%IRN(1), id%JCN(1), id%A(1), & id%NZ, & 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 INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL SMUMPS_693(id%IRN(1), & id%JCN(1), id%A(1), & id%NZ, & 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 DEALLOCATE(WK_REAL) DEALLOCATE (IWK,BURP,BUCP, & BURS,BUCS) ENDIF CALL MPI_BCAST( id%DKEEP(4),2,MPI_REAL, & MASTER, id%COMM, IERR ) 400 CONTINUE IF (id%MYID.EQ.MASTER) THEN CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF (INFO(1).LT.0) GOTO 530 ELSE IF (id%MYID.EQ.MASTER) THEN IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN IF ( KEEP(52) .eq. 5 .or. & KEEP(52) .eq. 6 ) THEN LWK = NZ ELSE LWK = 1 END IF LWK_REAL = 5 * N ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK_REAL GOTO 137 END IF ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK GOTO 137 END IF CALL SMUMPS_217(N, NZ, 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), INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN 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 = (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_761(id%ROWSCA(I), & id%DKEEP(6), & KEEP(259)) ENDDO IF (KEEP(50) .EQ. 0) THEN DO I = 1, id%N CALL SMUMPS_761(id%COLSCA(I), & id%DKEEP(6), & KEEP(259)) ENDDO ELSE CALL SMUMPS_765(id%DKEEP(6), KEEP(259)) ENDIF CALL SMUMPS_766(id%DKEEP(6), KEEP(259)) ENDIF 137 CONTINUE 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 ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N id%KEEP(255) = N*id%KEEP(253) ALLOCATE(RHS_MUMPS(id%KEEP(255)),stat=IERR) IF (IERR > 0) THEN INFO(1)=-13 INFO(2)=id%KEEP(255) IF (LP > 0) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ELSE id%KEEP(254)=id%LRHS id%KEEP(255)=id%LRHS*(id%KEEP(253)-1)+id%N RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN 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 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 ELSE id%KEEP(255)=1 ALLOCATE(RHS_MUMPS(1)) RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).lt.0 ) GOTO 530 KEEP(110)=ICNTL(24) CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(110).NE.1) KEEP(110)=0 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) ANORMINF = ZERO IF (KEEP(19).EQ.0) THEN SEUIL = ZERO ELSE CALL SMUMPS_27( id , ANORMINF, LSCAL ) IF (CNTL6 .LT. ZERO) THEN SEUIL = EPS*ANORMINF ELSE SEUIL = CNTL6*ANORMINF ENDIF IF (PROKG) WRITE(MPG,*) & ' ABSOLUTE PIVOT THRESHOLD for rank revealing =',SEUIL ENDIF SEUIL_LDLT_NIV2 = SEUIL IF (KEEP(110).EQ.0) THEN id%DKEEP(1) = -1.0E0 id%DKEEP(2) = ZERO ELSE IF (ANORMINF.EQ.ZERO) & CALL SMUMPS_27( id , ANORMINF, LSCAL ) IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE id%DKEEP(1) = 1.0E-5*EPS*ANORMINF 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 id%DKEEP(2) = -max(1.0E10*ANORMINF, & sqrt(huge(ANORMINF))/1.0E8) ELSE id%DKEEP(2) = ZERO ENDIF ENDIF ENDIF IF (KEEP(53).NE.0) THEN ID_ROOT =MUMPS_275(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%NSLAVES) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF IF ( associated( id%PIVNUL_LIST) ) DEALLOCATE(id%PIVNUL_LIST) IF(KEEP(110) .EQ. 1) THEN LPN_LIST = N ELSE LPN_LIST = 1 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 INFO(1)=-13 INFO(2)=LPN_LIST END IF id%PIVNUL_LIST(1:LPN_LIST) = 0 KEEP(109) = 0 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).lt.0 ) GOTO 530 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_REAL, & MASTER, id%COMM, IERR ) IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN IF(ANORMINF .EQ. ZERO) THEN CALL SMUMPS_27( id , ANORMINF, LSCAL ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL ELSE SEUIL = ZERO ENDIF ENDIF KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 IF ( id%MYID.EQ.MASTER ) THEN ITMP = ICNTL(23) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (WK_USER_PROVIDED) ITMP = 0 ITMP8 = int(ITMP, 8) KEEP8(4) = ITMP8 * 1000000_8 PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8=KEEP8(12) ELSE MAXS_BASE8=KEEP8(14) ENDIF IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) ELSE IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) IF (MAXS_BASE_RELAXED8 > huge(MAXS)) THEN WRITE(*,*) "Internal error: I8 overflow" CALL MUMPS_ABORT() ENDIF MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) MAXS = MAXS_BASE_RELAXED8 ELSE MAXS = 1_8 MAXS_BASE_RELAXED8 = 1_8 END IF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) .LT. 0) THEN GOTO 530 ENDIF IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN IF (KEEP(96).GT.0) THEN MAXS=int(KEEP(96),8) ELSE IF (KEEP8(4) .NE. 0_8) THEN PERLU_ON = .TRUE. CALL SMUMPS_214( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., KEEP(201), & PERLU_ON, TOTAL_BYTES) MAXS_BASE_RELAXED8=MAXS_BASE_RELAXED8 + & (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 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,4) ELSE MAXS=MAXS_BASE_RELAXED8 ENDIF ENDIF ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) .LT. 0) THEN GOTO 530 ENDIF CALL SMUMPS_713(PROKG, MPG, MAXS, id%NSLAVES, & id%COMM, "effective relaxed size of S =") CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 530 ENDIF IF ( I_AM_SLAVE ) THEN CALL SMUMPS_188( dble(id%COST_SUBTREES), & KEEP(64), KEEP(66),MAXS ) K28=KEEP(28) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), & max(0_8, MAXS-MAXS_BASE8)) CALL SMUMPS_185( id, MEMORY_MD_ARG, MAXS ) CALL SMUMPS_587(id, IERR) IF (IERR < 0) THEN INFO(1) = -90 INFO(2) = 0 GOTO 112 ENDIF IF (KEEP(201) .GT. 0) THEN IF (KEEP(201).EQ.1 & .AND.KEEP(50).EQ.0 & .AND.KEEP(251).NE.2 & ) THEN OOC_NB_FILE_TYPE=2 ELSE OOC_NB_FILE_TYPE=1 ENDIF IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN I8TMP = int(OOC_NB_FILE_TYPE,8) * 2_8 * int(KEEP(226),8) ELSE I8TMP = 2_8 * KEEP8(119) ENDIF I8TMP = I8TMP + int(max(KEEP(12),0),8) * & (I8TMP/100_8+1_8) I8TMP = min(I8TMP, 12000000_8) KEEP(100)=int(I8TMP) ENDIF IF (KEEP(201).EQ.1) THEN IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF IF (id%MYID_NODES .eq. MASTER) THEN write(6,*) ' PANEL: INIT and force STRAT_IO= ', & id%KEEP(99) ENDIF ENDIF 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), & OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1) < 0) THEN 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_575(id,MAXS) ELSE WRITE(*,*) "Internal error in SMUMPS_142" CALL MUMPS_ABORT() ENDIF IF(INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF #if ! defined(OLD_LOAD_MECHANISM) CALL SMUMPS_190(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) #endif IF (INFO(1).LT.0) GOTO 111 #if defined(stephinfo) write(*,*) 'proc ',id%MYID,' array of dist : ', & id%MEM_DIST(0:id%NSLAVES - 1) #endif END IF IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN ALLOCATE (id%S(MAXS),stat=IERR) KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN INFO(1) = -13 CALL MUMPS_735(MAXS, INFO(2)) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ELSE id%S => id%WK_USER(1:KEEP8(24)) ENDIF #if defined (LARGEMATRICES) END IF #endif 111 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP(55) .eq. 0 ) THEN IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE .and. KEEP(13) .ne. 0 ) THEN ALLOCATE( id%DBLARR( KEEP(13) ), stat = IERR ) ELSE ALLOCATE( id%DBLARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID, & ':Error allocating DBLARR : IERR = ', IERR INFO(1)=-13 INFO(2)=KEEP(13) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( I_AM_SLAVE .and. KEEP(14) .ne. 0 ) THEN ALLOCATE( id%INTARR( KEEP(14) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = KEEP(14) 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 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 id%DBLARR => id%A_ELT ELSE IF ( KEEP(13) .ne. 0 ) THEN ALLOCATE( id%DBLARR( KEEP(13) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = KEEP(13) 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 IF ( KEEP(38).NE.0 .AND. I_AM_SLAVE ) THEN CALL SMUMPS_165( id%N, & id%root, id%FILS(1), KEEP(38), id%KEEP(1), id%INFO(1) ) END IF 100 CONTINUE CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP( 55 ) .eq. 0 ) THEN IF (KEEP(38).NE.0 .AND. I_AM_SLAVE) THEN LWK = numroc( id%root%ROOT_SIZE, id%root%MBLOCK, & id%root%MYROW, 0, id%root%NPROW ) LWK = max( 1, LWK ) LWK = LWK* & numroc( id%root%ROOT_SIZE, id%root%NBLOCK, & id%root%MYCOL, 0, id%root%NPCOL ) LWK = max( 1, LWK ) ELSE LWK = 1 ENDIF IF (MAXS .LT. int(LWK,8)) THEN INFO(1) = -9 INFO(2) = LWK ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN ALLOCATE(IWK(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN INFO(1)=-13 INFO(2)=id%N END IF #if defined(LARGEMATRICES) IF ( associated (id%S) ) THEN DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LWK write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( .not. associated( id%INTARR ) ) THEN ALLOCATE( id%INTARR( 1 ) ) ENDIF #if defined(LARGEMATRICES) CALL SMUMPS_148(id%N, NZ, 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), & min(KEEP(39),id%NZ), & LP, id%COMM, id%root, KEEP,KEEP8, & id%FILS(1), IWK(1), & & id%INTARR(1), id%DBLARR(1), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), int(LWK,8), & id%ISTEP_TO_INIV2, id%I_AM_CAND, & id%CANDIDATES) write(6,*) '!!! A,IRN,JCN are freed during facto ' 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) KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN INFO(1) = -13 INFO(2) = MAXS NULLIFY(id%S) KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ELSE id%S => id%WK_USER(1:KEEP8(24)) ENDIF id%S(MAXS-LWK+1:MAXS) = WK(1:LWK) DEALLOCATE (WK) #else CALL SMUMPS_148(id%N, NZ, 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), & min(KEEP(39),id%NZ), & LP, id%COMM, id%root, KEEP(1),KEEP8(1), & id%FILS(1), IWK(1), & & id%INTARR(1), id%DBLARR(1), & 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) IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF ELSE CALL SMUMPS_145( id%N, & id%DBLARR( 1 ), max(1,KEEP( 13 )), & id%INTARR( 1 ), max(1,KEEP( 14 )), & id%PTRAR( 1 ), & id%PTRAR(id%N+1), & KEEP( 1 ), KEEP8(1), id%MYID, id%COMM, & min(id%KEEP(39),id%NZ), & & 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 IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( I_AM_SLAVE ) THEN NZ_locMAX = 0 CALL MPI_ALLREDUCE(id%NZ_loc, NZ_locMAX, 1, MPI_INTEGER, & MPI_MAX, id%COMM_NODES, IERR) CALL SMUMPS_282( id%N, & id%NZ_loc, & id, & id%DBLARR(1), KEEP(13), id%INTARR(1), & KEEP(14), id%PTRAR(1), id%PTRAR(id%N+1), & KEEP(1), KEEP8(1), id%MYID_NODES, & id%COMM_NODES, min(id%KEEP(39),NZ_locMAX), & 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), NSEND, NLOCAL, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN 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) 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) NLOCAL, NSEND END IF END IF IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN NSEND = 0 NLOCAL = 0 END IF CALL MPI_REDUCE( NSEND, NSEND_TOT, 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL, NLOCAL_TOT, 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT, NSEND_TOT END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF END IF ELSE IF (PROKG ) THEN CALL MUMPS_291(TIME) END IF IF ( id%MYID.eq.MASTER) &CALL SMUMPS_213( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) CALL SMUMPS_126( id%N, id%NELT, id%NA_ELT, & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & id%INTARR(1), id%DBLARR(1), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & id%S(1), MAXS, id%FILS(1), & id, id%root ) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,160) TIME CALL MUMPS_291(TIME) END IF END IF IF ( I_AM_SLAVE ) THEN CALL SMUMPS_528(id%MYID_NODES) SMUMPS_LBUFR_BYTES = KEEP( 44 ) * KEEP( 35 ) SMUMPS_LBUFR_BYTES = max( SMUMPS_LBUFR_BYTES, & 100000 ) PERLU = KEEP( 12 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF SMUMPS_LBUFR_BYTES = SMUMPS_LBUFR_BYTES & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUFR_BYTES)/100E0) IF (KEEP(48)==5) THEN KEEP8(21) = KEEP8(22) + int( real(max(PERLU,MIN_PERLU))* & real(KEEP8(22))/100E0,8) ENDIF SMUMPS_LBUF = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(43)) * real(KEEP(35)) ) SMUMPS_LBUF = max( SMUMPS_LBUF, 100000 ) SMUMPS_LBUF = SMUMPS_LBUF & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUF)/100E0) SMUMPS_LBUF = max(SMUMPS_LBUF, SMUMPS_LBUFR_BYTES+3*KEEP(34)) IF(id%KEEP(48).EQ.4)THEN SMUMPS_LBUFR_BYTES=SMUMPS_LBUFR_BYTES*5 SMUMPS_LBUF=SMUMPS_LBUF*5 ENDIF SMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN KKKK = MUMPS_275( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%NSLAVES ) IF ( KKKK .EQ. id%MYID_NODES ) THEN SMUMPS_LBUF_INT = SMUMPS_LBUF_INT + & 10 * & 2 * ( id%NE_STEPS(id%STEP(KEEP(38))) + 1 ) * id%NSLAVES & * KEEP(34) END IF END IF IF ( MP .GT. 0 ) 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) CALL SMUMPS_55( SMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID, & ':Error allocating small Send buffer:IERR=' & ,IERR INFO(1)= -13 INFO(2)= (SMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) GO TO 110 END IF CALL SMUMPS_53( SMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating Send buffer:IERR=' & ,IERR INFO(1)= -13 INFO(2)= (SMUMPS_LBUF+KEEP(34)-1)/KEEP(34) GO TO 110 END IF 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 WRITE(*,*) id%MYID,':Error allocating BUFR:IERR=' & ,IERR INFO(1)=-13 INFO(2)=id%LBUFR NULLIFY(id%BUFR) GO TO 110 END IF PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN MAXIS_ESTIM = KEEP(225) ELSE 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 WRITE(*,*) id%MYID,':Error allocating IS:IERR=',IERR INFO(1)=-13 INFO(2)=MAXIS NULLIFY(id%IS) GO TO 110 END IF LIW = MAXIS IF (associated( id%PTLUST_S )) DEALLOCATE(id%PTLUST_S) ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocatingPTLUST:IERR = ', & IERR INFO(1)=-13 INFO(2)=id%KEEP(28) 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 WRITE(*,*) id%MYID,':Error allocatingPTRFAC:IERR = ', & IERR INFO(1)=-13 INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) GOTO 100 END IF PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 3 * id%KEEP(28) IPOOL = ITLOC + id%N + id%KEEP(253) LPOOL = SMUMPS_505(id%KEEP(1),id%KEEP8(1)) ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', & IERR INFO(1)=-13 INFO(2)=IPOOL + LPOOL - 1 GOTO 110 END IF ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN WRITE(*,*) id%MYID,':Error allocating IWK : IERR = ', & IERR INFO(1)=-13 INFO(2)=2 * id%KEEP(28) GOTO 110 END IF ENDIF 110 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO( 1 ) .LT. 0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN CALL SMUMPS_60( id%LBUFR_BYTES ) IF (MP .GT. 0) THEN WRITE( MP, 170 ) MAXS, MAXIS, KEEP8(12), KEEP(15), KEEP(13), & KEEP(14), KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF PERLU_ON = .TRUE. CALL SMUMPS_214( id%KEEP(1), id%KEEP8(1), & id%MYID, id%N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .FALSE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) id%INFO(16) = TOTAL_MBYTES IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' ** Space in MBYTES used during factorization :', & id%INFO(16) END IF CALL MUMPS_243( 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 KEEP8(31)= 0_8 KEEP8(10) = 0_8 KEEP8(8)=0_8 INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = id%N ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT = id%NELT ELSE NELT = 1 END IF CALL SMUMPS_244( 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), INFO(1), RINFO(1), KEEP(1),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, 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) IF ( MP . GT. 0 .and. KEEP(38) .ne. 0 ) THEN WRITE( MP, 175 ) KEEP(49) END IF DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF IF ( KEEP(55) .eq. 0 ) THEN IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF ELSE DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN NULLIFY( id%DBLARR ) ELSE IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF END IF IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN 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 IF (associated(id%BUFR)) THEN DEALLOCATE(id%BUFR) NULLIFY(id%BUFR) END IF CALL SMUMPS_57( IERR ) CALL SMUMPS_59( IERR ) IF (KEEP(219).NE.0) THEN CALL SMUMPS_620() ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) CALL SMUMPS_770(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_591(IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ENDIF ENDIF CALL MUMPS_276( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) END IF END IF IF ( PROKG ) THEN CALL MUMPS_292(TIME) WRITE(MPG,180) TIME END IF PERLU_ON = .TRUE. CALL SMUMPS_214( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%LNA, id%NZ, & id%NA_ELT, & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & PERLU_ON, TOTAL_BYTES) KEEP8(7) = TOTAL_BYTES id%INFO(22) = TOTAL_MBYTES IF ( MP .gt. 0 ) THEN WRITE(MP,'(A,I10) ') & ' ** Effective minimum Space in MBYTES for facto :', & TOTAL_MBYTES ENDIF IF (I_AM_SLAVE) THEN K67 = KEEP8(67) ELSE K67 = 0_8 ENDIF CALL MUMPS_735(K67,id%INFO(21)) CALL SMUMPS_713(PROKG, MPG, K67, id%NSLAVES, & id%COMM, "effective space used in S (KEEP8(67) =") CALL MUMPS_243( 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 KEEP(33) = INFO(11) CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_646( KEEP8(31),KEEP8(6), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(6), INFOG(9)) CALL MPI_REDUCE( INFO(10), INFOG(10), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_ALLREDUCE( INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) KEEP(133) = INFOG(11) CALL MPI_REDUCE( 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) INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) CALL MUMPS_646( KEEP8(8), KEEP8(108), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(10), INFO(27)) CALL MUMPS_646( KEEP8(10),KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_735(KEEP8(110), INFOG(29)) IF (KEEP(258).NE.0) THEN RINFOG(13)=0.0E0 IF (KEEP(260).EQ.-1) THEN id%DKEEP(6)=-id%DKEEP(6) ENDIF CALL SMUMPS_764( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN IF (id%KEEP(23).NE.0) THEN CALL SMUMPS_767( & RINFOG(12), id%N, & id%STEP(1), & id%UNS_PERM(1) ) ENDIF ENDIF ENDIF IF(KEEP(110) .EQ. 1) THEN INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF INFOG(28)=KEEP(112)+KEEP(17) IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN INFO(18)=INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN DO I=1, KEEP(17) id%PIVNUL_LIST(KEEP(112)+I)=id%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE 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 IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%NPROCS END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (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 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) 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 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) IF ( PROKG ) THEN WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP8(6),INFOG(10), & INFOG(11), KEEP8(110) IF (id%KEEP(50) == 1 .OR. id%KEEP(50) == 2) THEN WRITE(MPG, 99987) INFOG(12) END IF IF (id%KEEP(50) == 0) THEN WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN WRITE(MPG, 99986) KEEP(98) ENDIF IF (id%KEEP(50) == 2) THEN WRITE(MPG, 99988) KEEP(229) WRITE(MPG, 99989) KEEP(230) ENDIF IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) IF (KEEP(110).NE.0.OR.KEEP(17).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) WRITE(MPG, 99981) INFOG(14) IF ((KEEP(201).EQ.0.OR.KEEP(201).EQ.2).AND. & KEEP(50).EQ.0) THEN WRITE(MPG, 99980) KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN 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 500 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL SMUMPS_592(id,IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF ELSE IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) KEEP8(23)=0_8 END IF END IF 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL SMUMPS_183( INFO(1), IERR ) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) 530 CONTINUE IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) id%KEEP(13) = KEEP13_SAVE RETURN 120 FORMAT(/' LOCAL REDISTRIB: DATA LOCAL/SENT =',I12,I12) 125 FORMAT(/' REDISTRIB: TOTAL DATA LOCAL/SENT =',I12,I12) 130 FORMAT(/' ****** FACTORIZATION STEP ********'/) 160 FORMAT(' GLOBAL TIME FOR MATRIX DISTRIBUTION =',F12.4) 165 FORMAT(' Convergence error after scaling for INF-NORM', & ' (option 7/8) =',D9.2) 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 =',I12/ & ' Size of internal working array IS =',I12/ & ' MINIMUM (ICNTL(14)=0) size of S =',I12/ & ' MINIMUM (ICNTL(14)=0) size of IS =',I12/ & ' REAL SPACE FOR ORIGINAL MATRIX =',I12/ & ' INTEGER SPACE FOR ORIGINAL MATRIX =',I12/ & ' REAL SPACE FOR FACTORS =',I12/ & ' INTEGER SPACE FOR FACTORS =',I12/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12) 172 FORMAT(/' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' NUMBER OF WORKING PROCESSES =',I12/ & ' OUT-OF-CORE OPTION (ICNTL(22)) =',I12/ & ' REAL SPACE FOR FACTORS =',I12/ & ' INTEGER SPACE FOR FACTORS =',I12/ & ' MAXIMUM FRONTAL SIZE (ESTIMATED) =',I12/ & ' NUMBER OF NODES IN THE TREE =',I12) 173 FORMAT( ' PERFORM FORWARD DURING FACTO, NRHS =',I12) 175 FORMAT(/' NUMBER OF ENTRIES FOR // ROOT =',I12) 180 FORMAT(/' ELAPSED TIME FOR FACTORIZATION =',F12.4) 99977 FORMAT( ' INFOG(34) DETERMINANT (base 2 exponent) =',I12) 99978 FORMAT( ' RINFOG(12) DETERMINANT (real part) =',F12.4) 99980 FORMAT( ' KEEP8(108) Extra copies IP stacking =',I12) 99981 FORMAT( ' INFOG(14) NUMBER OF MEMORY COMPRESS =',I12) 99982 FORMAT( ' INFOG(13) NUMBER OF DELAYED PIVOTS =',I12) 99983 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(16) =',I12) 99991 FORMAT( ' NB OF NULL PIVOTS DETECTED BY ICNTL(24) =',I12) 99992 FORMAT( ' INFOG(28) ESTIMATED DEFICIENCY =',I12) 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 =',I12/ & ' INFOG(10) INTEGER SPACE FOR FACTORS =',I12/ & ' INFOG(11) MAXIMUM FRONT SIZE =',I12/ & ' INFOG(29) NUMBER OF ENTRIES IN FACTORS =',I12) 99985 FORMAT( ' INFOG(12) NB OF OFF DIAGONAL PIVOTS =',I12) 99986 FORMAT( ' INFOG(25) NB TINY PIVOTS/STATIC PIVOTING =',I12) 99987 FORMAT( ' INFOG(12) NB OF NEGATIVE PIVOTS =',I12) 99988 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 1 nodes =',I12) 99989 FORMAT( ' NUMBER OF 2x2 PIVOTS in type 2 nodes =',I12) END SUBROUTINE SMUMPS_142 SUBROUTINE SMUMPS_713(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 INTEGER(8) MAX_VAL INTEGER IERR, MASTER REAL LOC_VAL, AVG_VAL PARAMETER(MASTER=0) CALL MUMPS_646( 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,I12) END SUBROUTINE SMUMPS_713 SUBROUTINE SMUMPS_770(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER IERR, MASTER 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 INTEGER MUMPS_275 EXTERNAL MUMPS_275 IF (id%INFO(1) .LT. 0) RETURN IF (id%KEEP(60) .EQ. 0) RETURN ID_SCHUR =MUMPS_275( & 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 IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE LD_SCHUR = -999999 SIZE_SCHUR = id%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ELSE RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN 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 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 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 IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF RETURN ENDIF IF (id%KEEP(252).EQ.0) THEN IF ( ID_SCHUR .EQ. MASTER ) THEN CALL SMUMPS_756( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE BL8=int(huge(BL4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) IF ( id%MYID .eq. ID_SCHUR ) THEN 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 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 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 CALL scopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_REAL, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE 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 IF (id%KEEP(221).EQ.1) THEN 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 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 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_770 SUBROUTINE SMUMPS_83 & ( N, MAPPING, NZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NZ, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NZ ), JCN( NZ ) INTEGER MAPPING( NZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_275, MUMPS_330 EXTERNAL MUMPS_275, MUMPS_330 INTEGER K, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K INODE = FILS( INODE ) K = K + 1 END DO DO K = 1, NZ IOLD = IRN( K ) JOLD = JCN( K ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K ) = -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_330( PROCNODE(abs(STEP(IARR))), & SLAVEF ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_275( PROCNODE(abs(STEP(IARR))), & SLAVEF ) + 1 ELSE DEST = MUMPS_275( 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( K ) = DEST END DO RETURN END SUBROUTINE SMUMPS_83 SUBROUTINE SMUMPS_282( & N, NZ_loc, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND, NLOCAL, & ISTEP_TO_INIV2, CANDIDATES & ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NZ_loc TYPE (SMUMPS_STRUC) :: id INTEGER LDBLARR, LINTARR REAL DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER 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_275, MUMPS_330, numroc, & MUMPS_810 EXTERNAL MUMPS_275, MUMPS_330, numroc, & MUMPS_810 INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ), MSGSOU REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER END_MSG_2_RECV INTEGER I, K, I1, IA 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 IACT( SLAVEF ), IREQI( SLAVEF ), IREQR( SLAVEF ) LOGICAL SEND_ACTIVE( SLAVEF ) LOGICAL FLAG INTEGER NSEND, NLOCAL INTEGER MASTER_NODE, ISTEP NSEND = 0 NLOCAL = 0 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF 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 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_276( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) RETURN ARROW_ROOT = 0 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((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 K = 1, NZ_loc 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_102( & 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(K) JOLD = id%JCN_loc(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) CYCLE VAL = id%A_loc(K) 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_330( PROCNODE_STEPS(ISTEP), & SLAVEF ) MASTER_NODE= MUMPS_275( PROCNODE_STEPS(ISTEP), & SLAVEF ) TYPESPLIT = MUMPS_810( 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 NLOCAL = NLOCAL + 1 NSEND = NSEND + SLAVEF -1 else if (DEST .eq.MYID ) then NLOCAL = NLOCAL + 1 else NSEND = NSEND + 1 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_101( 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_101( 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_101( 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_101( 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_101( 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_101( 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_102( & 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 DEALLOCATE( IW4 ) DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) DEALLOCATE( BUFRECI ) DEALLOCATE( BUFRECR ) RETURN END SUBROUTINE SMUMPS_282 SUBROUTINE SMUMPS_101( 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 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 PTRAIW( N ), PTRARW( N ), 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, 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_102( & 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_102( & 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_101 SUBROUTINE SMUMPS_102 & ( 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 PTRAIW( N ), PTRARW( N ), PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA REAL A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_330, MUMPS_275 EXTERNAL MUMPS_330, MUMPS_275 INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID, & ILOCROOT, JLOCROOT INTEGER IA, IS1, ISHIFT, IIW, IS, IAS, 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_330( & 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 IA = PTRARW(IARR) DBLARR(IA) = DBLARR(IA) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = INTARR(IS1) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW = IS1 + ISHIFT + 2 INTARR(IIW) = JARR IS = PTRARW(IARR) IAS = IS + ISHIFT DBLARR(IAS) = VAL ENDIF ELSE IARR = -IARR ISHIFT = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IPROC = MUMPS_275( 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_310( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE SMUMPS_102 SUBROUTINE SMUMPS_151( NRHS, N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER NRHS, N,LIWW,LWC,POSWCB,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28),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 SIZFR = SIZFR * NRHS IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE SMUMPS_151 SUBROUTINE SMUMPS_95(NRHS,N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER NRHS,N,LIWW,LWC,POSWCB,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28),PTRACB(KEEP28) REAL W(LWC) INTEGER IPTIW,IPTA,SIZFI,SIZFR,LONGI,LONGR INTEGER I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = IWCB(IPTIW+1) SIZFI = 2 SIZFR = SIZFR * NRHS IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I ) 20 CONTINUE DO 30 I=0,LONGR-1 W(IPTA + SIZFR - I) = W(IPTA - I ) 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 = IWCB(IPTIW+1) SIZFI = 2 SIZFR = SIZFR * NRHS IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE SMUMPS_95 SUBROUTINE SMUMPS_205(MTYPE, IFLAG, N, NZ, & LHS, WRHS, W, RHS, GIVSOL, SOL, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,NZ,IFLAG,ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) REAL RHS(N),LHS(N) REAL WRHS(N),SOL(*) REAL W(N) REAL RESMAX,RESL2,XNORM, ERMAX,MAXSOL, & COMAX, SCLNRM, ERL2, ERREL REAL ANORM,DZERO,EPSI LOGICAL GIVSOL,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0E0 EPSI = 0.1E-9 ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RHS(K))) RESL2 = RESL2 + abs(RHS(K)) * abs(RHS(K)) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF (XNORM .GT. EPSI) THEN SCLNRM = RESMAX / (ANORM * XNORM) ELSE IFLAG = IFLAG + 2 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) &' max-NORM of computed solut. is zero' SCLNRM = RESMAX / ANORM ENDIF RESL2 = sqrt(RESL2) ERMAX = DZERO COMAX = DZERO ERL2 = DZERO IF (.NOT.GIVSOL) THEN IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM ELSE MAXSOL = DZERO DO 60 K = 1, N MAXSOL = max(MAXSOL, abs(SOL(K))) 60 CONTINUE DO 70 K = 1, N ERL2 = abs(LHS(K) - SOL(K)) ** 2 + ERL2 ERMAX = max(ERMAX, abs(LHS(K) - SOL(K))) 70 CONTINUE DO 80 K = 1, N IF (abs(SOL(K)) .GT. EPSI) THEN COMAX = max(COMAX, (abs(LHS(K) - SOL(K)) / abs(SOL(K)))) ENDIF 80 CONTINUE ERL2 = sqrt(ERL2) IF (MAXSOL .GT. EPSI) THEN ERREL = ERMAX / MAXSOL ELSE IFLAG = IFLAG + 2 IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) &' MAX-NORM of exact solution is zero' ERREL = ERMAX ENDIF IF (PROK) WRITE( MPRINT, 100 ) ERMAX, ERL2, ERREL, COMAX, RESMAX & , RESL2, ANORM, XNORM, SCLNRM ENDIF 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 100 FORMAT (/' ERROR IS ............ (MAX-NORM) =',1PD9.2/ & ' ............ (2-NORM) =',1PD9.2/ & ' RELATIVE ERROR........... (MAX-NORM) =',1PD9.2/ & ' Comp. Wise ERROR......... (MAX-NORM) =',1PD9.2/ & ' AND RESIDUAL IS ......... (MAX-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' NORM OF input MATRIX ... (MAX-NORM) =',1PD9.2/ & ' NORM of computed SOLUT... (MAX-NORM) =',1PD9.2/ & ' SCALED RESIDUAL ......... (MAX-NORM) =',1PD9.2) END SUBROUTINE SMUMPS_205 SUBROUTINE SMUMPS_206(NZ, N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, JOB, COND, MAXIT, NOITER, LP, KEEP,KEEP8, & ARRET ) IMPLICIT NONE INTEGER NZ, N, KASE, KEEP(500), JOB 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, MAXIT, NOITER REAL COND(2),OMEGA(2) REAL ARRET REAL CGCE, CTAU DATA CTAU /1.0E3/, CGCE /0.2E0/ LOGICAL LCOND1, LCOND2 INTEGER IFLAG, JUMP, I, IMAX REAL ERX, DXMAX REAL CONVER, OM1, OM2, DXIMAX REAL ZERO, ONE,TAU, DD REAL OLDOMG(2) INTEGER SMUMPS_IXAMAX INTRINSIC abs, max SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX, CONVER, & OM1, OLDOMG, IFLAG DATA ZERO /0.0E0/, ONE /1.0E0/ IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO OM1 = ZERO IFLAG = 0 NOITER = 0 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 DO 20 I = 1, N X(I) = X(I) + Y(I) 20 CONTINUE IF (NOITER .GT. MAXIT) THEN IFLAG = IFLAG + 8 GOTO 70 ENDIF 30 CONTINUE KASE = 14 JUMP = 5 RETURN 35 CONTINUE IMAX = SMUMPS_IXAMAX(N, X, 1) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO 40 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 + TAU) .GT. TAU) 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 40 CONTINUE OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) GOTO 70 IF (MAXIT .EQ. 0) GOTO 70 IF (NOITER .GT. 1 .AND. OM2 .GT. OM1 * CGCE) THEN CONVER = OM2 / OM1 IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO 50 I = 1, N X(I) = C_W(I) 50 CONTINUE ENDIF GOTO 70 ENDIF DO 60 I = 1, N C_W(I) = X(I) 60 CONTINUE OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 NOITER = NOITER + 1 KASE = 2 JUMP = 2 RETURN 70 KASE = 0 IF (JOB .LE. 0) GOTO 170 DO 80 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 80 CONTINUE DO 90 I = 1, N C_W(I) = X(I) * D(I) 90 CONTINUE IMAX = SMUMPS_IXAMAX(N, C_W(1), 1) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CALL SMUMPS_218(N, KASE, Y, COND(1), C_W, IW(1, 2)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL SMUMPS_204(N, Y, D) IF (KASE .EQ. 2) CALL SMUMPS_204(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL SMUMPS_204(N, Y, R_W) IF (KASE .EQ. 2) CALL SMUMPS_204(N, Y, D) GOTO 100 120 IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CALL SMUMPS_218(N, KASE, Y, COND(2), C_W, IW(1, 2)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL SMUMPS_204(N, Y, D) IF (KASE .EQ. 2) CALL SMUMPS_204(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL SMUMPS_204(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL SMUMPS_204(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 KASE = -IFLAG RETURN END SUBROUTINE SMUMPS_206 SUBROUTINE SMUMPS_207(A, NZ, N, IRN, ICN, Z, KEEP,KEEP8) INTEGER NZ, N, I, J, K, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN(NZ), ICN(NZ) REAL A(NZ) REAL Z(N) REAL ZERO INTRINSIC abs DATA ZERO /0.0E0/ DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1, NZ 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, NZ 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 RETURN END SUBROUTINE SMUMPS_207 SUBROUTINE SMUMPS_289(A, NZ, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA) INTEGER, intent(in) :: NZ, N, KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) REAL, intent(in) :: A(NZ) REAL, intent(in) :: COLSCA(N) REAL, intent(out) :: Z(N) REAL ZERO DATA ZERO /0.0E0/ INTEGER I, J, K DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1, NZ 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, NZ 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_289 SUBROUTINE SMUMPS_208(A, NZ, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, intent(in) :: NZ, N, KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) REAL, intent(in) :: A(NZ), RHS(N), X(N) REAL, intent(out) :: W(N) REAL, intent(out) :: R(N) INTEGER I, K, J REAL ZERO DATA ZERO /0.0E0/ REAL D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. (J .LT. 1)) & CYCLE D = A(K) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF ((I.NE.J) .AND. (KEEP(50).NE.0) ) THEN D = A(K) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_208 SUBROUTINE SMUMPS_204(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_204 SUBROUTINE SMUMPS_218(N, KASE, X, EST, W, IW) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) REAL W(N), X(N) REAL 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_218 SUBROUTINE SMUMPS_278( MTYPE, N, NZ, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N, NZ INTEGER IRN( NZ ), ICN( NZ ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL, intent(in) :: ASPK( NZ ) REAL, intent(in) :: LHS( N ), WRHS( N ) REAL, intent(out):: RHS( N ) REAL, intent(out):: W( N ) INTEGER K, I, J REAL DZERO PARAMETER(DZERO = 0.0E0) DO 10 K = 1, N W(K) = DZERO RHS(K) = WRHS(K) 10 CONTINUE IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(I) = RHS(I) - ASPK(K) * LHS(J) W(I) = W(I) + abs(ASPK(K)) ENDDO ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(J) = RHS(J) - ASPK(K) * LHS(I) W(J) = W(J) + abs(ASPK(K)) ENDDO ENDIF ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE RHS(I) = RHS(I) - ASPK(K) * LHS(J) W(I) = W(I) + abs(ASPK(K)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K) * LHS(I) W(J) = W(J) + abs(ASPK(K)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_278 SUBROUTINE SMUMPS_121( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL A_ELT(NA_ELT) REAL LHS( N ), WRHS( N ), RHS( N ) REAL W(N) CALL SMUMPS_257(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL SMUMPS_119( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE SMUMPS_121 SUBROUTINE SMUMPS_119( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL A_ELT(NA_ELT) REAL TEMP REAL W(N) INTEGER K, I, J, IEL, SIZEI, IELPTR REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K = 1 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( K )) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K)) K = K + 1 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( K )) K = K + 1 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K )) K = K + 1 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_119 SUBROUTINE SMUMPS_135(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR, NA_ELT INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL COLSCA(N) REAL A_ELT(NA_ELT) REAL W(N) REAL TEMP, TEMP2 INTEGER K, I, J, IEL, SIZEI, IELPTR REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K = 1 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( K )) * TEMP2 K = K + 1 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( K )) * TEMP2 K = K + 1 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( K )*COLSCA(ELTVAR( IELPTR + J)) ) K = K + 1 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K )*COLSCA(ELTVAR( IELPTR + I))) K = K + 1 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_135 SUBROUTINE SMUMPS_122( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR, NA_ELT INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) REAL A_ELT( NA_ELT ), 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_122 SUBROUTINE SMUMPS_643( & 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_726(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_578(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_577( & 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_682(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_643 SUBROUTINE SMUMPS_257( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) REAL A_ELT( * ), X( N ), Y( N ) INTEGER IEL, I , J, K, SIZEI, IELPTR REAL TEMP REAL ZERO PARAMETER( ZERO = 0.0E0 ) Y = 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 K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & 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 ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE SMUMPS_257 SUBROUTINE SMUMPS_192 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE INTEGER N, NZ_loc INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) REAL A_loc( NZ_loc ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE INTEGER I, J, K REAL ZERO PARAMETER( ZERO = 0.0E0 ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ENDDO ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(I) ENDDO END IF ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE SMUMPS_192 SUBROUTINE SMUMPS_256( N, NZ, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM ) INTEGER N, NZ, LDLT, MTYPE, MAXTRANS INTEGER IRN( NZ ), ICN( NZ ) INTEGER PERM( N ) REAL ASPK( NZ ), X( N ), Y( N ) INTEGER K, I, J REAL PX( N ) REAL ZERO PARAMETER( ZERO = 0.0E0 ) Y = ZERO 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 IF (MTYPE .EQ. 1) THEN DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K) * PX(J) ENDDO ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K) * PX(I) ENDDO ENDIF ELSE DO K = 1, NZ I = IRN(K) J = ICN(K) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K) * 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 RETURN END SUBROUTINE SMUMPS_256 SUBROUTINE SMUMPS_193 &( N, NZ_loc, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE INTEGER N, NZ_loc INTEGER IRN_loc( NZ_loc ), JCN_loc( NZ_loc ) REAL A_loc( NZ_loc ), X( N ) REAL Y_loc( N ) INTEGER LDLT, MTYPE INTEGER I, J, K REAL RZERO PARAMETER( RZERO = 0.0E0 ) Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ) ENDDO ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(I) ) ENDDO END IF ELSE DO K = 1, NZ_loc I = IRN_loc(K) J = JCN_loc(K) 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(K) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE SMUMPS_193 mumps-4.10.0.dfsg/src/mumps_common.c0000644000175300017530000000654011562233011017544 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #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_AFFECT_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_AFFECT_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_AFFECT_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_AFFECT_UNS_PERM(MUMPS_INT * f77uns_perm) { MUMPS_UNS_PERM = f77uns_perm; } void MUMPS_CALL MUMPS_NULLIFY_C_UNS_PERM() { MUMPS_UNS_PERM = 0; } mumps-4.10.0.dfsg/src/mumps_ooc_common.F0000644000175300017530000001367611562233013020361 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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*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_676(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_676 SUBROUTINE MUMPS_677(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_677 SUBROUTINE MUMPS_796 & (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_796 INTEGER FUNCTION MUMPS_808 & (FWDORBWD, MTYPE, K201, K50) USE MUMPS_OOC_COMMON INTEGER, intent(in) :: MTYPE, K201, K50 CHARACTER*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_808", & TYPEF_L, TYPEF_U CALL MUMPS_ABORT() ENDIF IF (FWDORBWD .NE. 'F' .AND. FWDORBWD .NE. 'B') THEN WRITE(*,*) "Internal error in MUMPS_808,",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_808=TYPEF_U ELSE MUMPS_808=TYPEF_L ENDIF ELSE IF(K50.EQ.0)THEN IF(MTYPE.NE.1)THEN MUMPS_808=TYPEF_L ELSE MUMPS_808=TYPEF_U ENDIF ELSE MUMPS_808=TYPEF_L ENDIF ENDIF ELSE MUMPS_808 = 1 ENDIF RETURN END FUNCTION MUMPS_808 mumps-4.10.0.dfsg/src/mumps_io_basic.c0000644000175300017530000007327111562233011020031 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #include "mumps_io_basic.h" #include "mumps_io_err.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; */ int mumps_elementary_data_size; int mumps_io_is_init_called; int mumps_io_myid; int mumps_io_max_file_size; /* int mumps_io_nb_file; */ int mumps_io_flag_async; int mumps_io_k211; /* int mumps_flag_open;*/ int mumps_directio_flag; int mumps_io_nb_file_type; /* Functions */ int mumps_set_file(int type,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) int fd; char buf[64]; /* for error message */ #endif mumps_file_struct *mumps_io_pfile_pointer_array; /* if ((mumps_files+type)->mumps_io_current_file_number >= ((mumps_files+type)->mumps_io_nb_file)-1){*/ if (file_number_arg > ((mumps_files+type)->mumps_io_nb_file)-1){ /* Exception : probably thrown because of a bad estimation of number of files. */ /* We increase the number of file needed and then realloc. */ ((mumps_files+type)->mumps_io_nb_file)++; (mumps_files+type)->mumps_io_pfile_pointer_array=realloc((void *)(mumps_files+type)->mumps_io_pfile_pointer_array,((mumps_files+type)->mumps_io_nb_file)*sizeof(mumps_file_struct)); if((mumps_files+type)->mumps_io_pfile_pointer_array==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } ((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 */ ((mumps_files+type)->mumps_io_current_file_number)=file_number_arg; if((mumps_io_pfile_pointer_array+file_number_arg)->is_opened!=0){ ((mumps_files+type)->mumps_io_current_file_number)=file_number_arg; return 0; } /* #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; */ } int mumps_compute_where_to_write(const double to_be_written,const int type,long long vaddr,size_t already_written){ /* Check if the current file has enough memory to receive the whole block*/ int ret_code; int file; mumps_file_struct *current_file; long long vaddr_loc; 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; } int mumps_prepare_pointers_for_write(double to_be_written,int * pos_in_file, int * file_number,const int type,long long vaddr,size_t already_written){ 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 int mumps_gen_file_info(long long vaddr, int * pos, int * file){ *file=(int)(vaddr/(long long)mumps_io_max_file_size); *pos=(int)(vaddr%(long long)mumps_io_max_file_size); return 0; } int mumps_compute_nb_concerned_files(long long block_size, int * nb_concerned_files,long long vaddr){ 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=(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; } int mumps_io_do_write_block(void * address_block, long long block_size, int * type_arg, long long vaddr, int * ierr){ /* Type of fwrite : size_t fwrite(const void *ptr, size_t size, *size_t nmemb, FILE *stream); */ size_t write_size; int i; int nb_concerned_files=0; int ret_code,file_number_loc,pos_in_file_loc; double to_be_written; #if ! defined( MUMPS_WIN32 ) int* file; #else FILE** file; #endif int where; void* loc_addr; 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)(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 /* printf("1 write -> size = %d | off = %d | file = %d (%d) \n",(int)write_size,where,*file,((mumps_files+type)->mumps_io_current_file)->write_pos); */ 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+((int)write_size); to_be_written=to_be_written-((int)write_size); loc_addr=(void*)((size_t)loc_addr+write_size); /* mumps_io_write_pos=mumps_io_write_pos+((int)write_size); */ /* to_be_written=to_be_written-((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+((int)write_size*mumps_elementary_data_size); to_be_written=to_be_written-((int)write_size*mumps_elementary_data_size); loc_addr=(void*)((size_t)loc_addr+(size_t)((int)write_size*mumps_elementary_data_size)); /* mumps_io_write_pos=mumps_io_write_pos+((int)write_size*mumps_elementary_data_size); */ /* to_be_written=to_be_written-((int)write_size*mumps_elementary_data_size); */ /* loc_addr=(void*)((size_t)loc_addr+(size_t)((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; } int mumps_io_do_read_block(void * address_block, long long block_size, int * type_arg, long long vaddr, int * ierr){ size_t size; #if ! defined( MUMPS_WIN32 ) int* file; #else FILE** file; #endif double read_size; int local_fnum,local_offset; void *loc_addr; long long vaddr_loc; 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=(int)(vaddr_loc/(long long)mumps_io_max_file_size); local_offset=(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,(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; } int mumps_free_file_pointers(int *step){ 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(int* nb,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 */ int mumps_io_alloc_file_struct(int* nb,int which) { 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; } int mumps_init_file_structure(int* _myid, long long *total_size_io,int *size_element,int *nb_file_type,int *flag_tab) { /* Computes the number of files needed. Uses ceil value. */ int ierr; #if ! defined( MUMPS_WIN32 ) int k211_loc; int mumps_flag_open; #endif int i,nb; 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=(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; #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; #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; #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; } int mumps_init_file_name(char* mumps_dir,char* mumps_file, int* mumps_dim_dir,int* mumps_dim_file,int* _myid){ int i; char *tmp_dir,*tmp_fname; char base_name[20]; 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; } int mumps_io_get_nb_files(int* nb_files, const int* type){ *nb_files=((mumps_files+*type)->mumps_io_last_file_opened)+1; return 0; } int mumps_io_get_file_name(int* indice,char* name,int* length,int* type){ int i; i=(*indice)-1; strcpy(name,(((mumps_files+*type)->mumps_io_pfile_pointer_array)+i)->name); *length=(int)strlen(name)+1; return 0; } int mumps_io_alloc_pointers(int* nb_file_type,int * dim){ int ierr; 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; } int mumps_io_set_file_name(int* indice,char* name,int* length,int* type){ 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; } int mumps_io_open_files_for_read(){ 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; } int mumps_io_set_last_file(int* dim,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 int mumps_io_protect_pointers(){ pthread_mutex_lock(&mumps_io_pwrite_mutex); return 0; } int mumps_io_unprotect_pointers(){ pthread_mutex_unlock(&mumps_io_pwrite_mutex); return 0; } int mumps_io_init_pointers_lock(){ pthread_mutex_init(&mumps_io_pwrite_mutex,NULL); return 0; } int mumps_io_destroy_pointers_lock(){ pthread_mutex_destroy(&mumps_io_pwrite_mutex); return 0; } # endif /*WITH_PFUNC*/ #endif /* _WIN32 && WITHOUT_PTHREAD */ int mumps_io_read__(void * file,void * loc_addr,size_t size,int local_offset,int type){ 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 ) int mumps_io_read_os_buff__(void * file,void * loc_addr,size_t size,int local_offset){ size_t ret_code; /* printf("Read with buff %d %d %d\n",(int) size, local_offset,*((int *)file)); */ # ifdef WITH_PFUNC ret_code=pread(*(int *)file,loc_addr,size,local_offset); # else lseek(*(int *)file,(long) local_offset,SEEK_SET); ret_code=read(*(int *)file,loc_addr,size); # endif if((int) ret_code==-1){ return mumps_io_sys_error(-90,"Problem with low level read"); } return 0; } #endif #if defined( MUMPS_WIN32 ) int mumps_io_read_win32__(void * file,void * loc_addr,size_t size,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){ return mumps_io_error(-90,"Problem with I/O operation\n"); } return 0; } #endif int mumps_io_write__(void *file, void *loc_addr, size_t write_size, int where,int type){ 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 ) int mumps_io_write_os_buff__(void *file, void *loc_addr, size_t write_size, int where){ size_t ret_code; /* printf("write with buff %d %d %d\n",(int) write_size, where,*((int *)file)); */ # ifdef WITH_PFUNC ret_code=pwrite(*(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(*(int *)file,(long)where,SEEK_SET); ret_code=write(*(int *)file,loc_addr,write_size); # endif if((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 ) int mumps_io_write_win32__(void *file, void *loc_addr, size_t write_size, 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){ return mumps_io_error(-90,"Problem with I/O operation\n"); } return 0; } #endif 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 */ 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(*(int *)file, &file_info); *size = (size_t)file_info.st_size; #endif return 0; } mumps-4.10.0.dfsg/src/dmumps_part7.F0000644000175300017530000007607311562233066017442 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE DMUMPS_635(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(40), MPG KEEP(19)=0 RETURN END SUBROUTINE DMUMPS_635 SUBROUTINE DMUMPS_634(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_634 SUBROUTINE DMUMPS_637(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) id NULLIFY(id%root%QR_TAU) RETURN END SUBROUTINE DMUMPS_637 SUBROUTINE DMUMPS_636(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 RETURN END SUBROUTINE DMUMPS_636 SUBROUTINE DMUMPS_146( MYID, root, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP) IMPLICIT NONE INCLUDE 'dmumps_root.h' INCLUDE 'mpif.h' TYPE ( DMUMPS_ROOT_STRUC ) :: root INTEGER N, IROOT, COMM, LIW, MYID, IFREE INTEGER(8) :: LA INTEGER(8) :: LWK DOUBLE PRECISION WK( LWK ) INTEGER KEEP(500) DOUBLE PRECISION DKEEP(30) 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 ) INTEGER IOLDPS INTEGER(8) :: IAPOS 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_320( 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_320( 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 (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in DMUMPS_146:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL DMUMPS_763(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_768( & 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_146 SUBROUTINE DMUMPS_556( & 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_556 SUBROUTINE DMUMPS_550(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_550 SUBROUTINE DMUMPS_547( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL) IMPLICIT NONE INTEGER N,NZ,NCMP,LW,IWFR,IERROR INTEGER ICNTL(40),KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN(NZ),ICN(NZ),IW(LW),PIV(N),IPE(N+1) INTEGER LEN(N),IQ(N),FLAG(N),ICMP(N) INTEGER MP,N11,N22,NDUP INTEGER I,K,J,N1,LAST,K1,K2,L 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 K=1,NZ I = IRN(K) J = ICN(K) I = ICMP(I) J = ICMP(J) 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 IPE(J) = IPE(J) + 1 ENDIF ENDIF ENDDO IQ(1) = 1 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,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO DO K=1,LAST IW(K) = 0 ENDDO IWFR = LAST + 1 DO K=1,NZ I = IRN(K) J = ICN(K) 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 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO NDUP = 0 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1 IF (K1.GT.K2) THEN LEN(I) = 0 IQ(I) = 0 ELSE DO K=K1,K2 J = -IW(K) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1 IW(L) = 0 IW(K) = 0 ELSE IW(L) = I IW(K) = J FLAG(J) = I ENDIF ENDDO 250 IQ(I) = IQ(I) - IPE(I) IF (NDUP.EQ.0) LEN(I) = IQ(I) ENDIF ENDDO IF (NDUP.NE.0) THEN IWFR = 1 DO I=1,NCMP K1 = IPE(I) IF (IQ(I).EQ.0) THEN LEN(I) = 0 IPE(I) = IWFR CYCLE ENDIF K2 = K1 + IQ(I) - 1 L = IWFR IPE(I) = IWFR DO K=K1,K2 IF (IW(K).NE.0) THEN IW(IWFR) = IW(K) IWFR = IWFR + 1 ENDIF ENDDO LEN(I) = IWFR - L ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + LEN(NCMP) IWFR = IPE(NCMP+1) RETURN END SUBROUTINE DMUMPS_547 SUBROUTINE DMUMPS_551( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER N, NE, ICNTL(10), INFO(10),LSC INTEGER CPERM(N),PIV_OUT(N),IP(N+1),IRN(NE), DIAG(N) DOUBLE PRECISION SCALING(LSC),WEIGHT(N+2) INTEGER MARKED(N),FLAG(N) INTEGER NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER I,CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT,BEST_BEG INTEGER L1,L2,PTR_SET1,PTR_SET2,TUP,T22 DOUBLE PRECISION BEST_SCORE,CUR_VAL,TMP,VAL DOUBLE PRECISION INITSCORE, DMUMPS_739, & DMUMPS_740, DMUMPS_741 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 = IP(CUR_EL+1)-IP(CUR_EL) L2 = 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_741( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & DMUMPS_739(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 = IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH) L2 = 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_741( & 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_739(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_739(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = DMUMPS_740(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_739(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = DMUMPS_740(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_551 FUNCTION DMUMPS_739(A,B,T) IMPLICIT NONE DOUBLE PRECISION DMUMPS_739 DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN DMUMPS_739 = A+B ELSE DMUMPS_739 = A*B ENDIF END FUNCTION DMUMPS_739 FUNCTION DMUMPS_740(A,B,T) IMPLICIT NONE DOUBLE PRECISION DMUMPS_740 DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN DMUMPS_740 = A-B ELSE DMUMPS_740 = A/B ENDIF END FUNCTION DMUMPS_740 FUNCTION DMUMPS_741(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE DOUBLE PRECISION DMUMPS_741 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_741 = 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_741 = dble(L1+L2-2) DMUMPS_741 = -(DMUMPS_741**2)/2.0D0 ELSE IF(MERGE .EQ. 1) THEN DMUMPS_741 = - dble(L1+L2-4) * dble(L1-2) ELSE IF(MERGE .EQ. 2) THEN DMUMPS_741 = - dble(L1+L2-4) * dble(L2-2) ELSE DMUMPS_741 = - dble(L1-2) * dble(L2-2) ENDIF ELSE DMUMPS_741 = VAL ENDIF RETURN END FUNCTION SUBROUTINE DMUMPS_622(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_622 SUBROUTINE DMUMPS_623 & (NA,N,NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, MedDens, NBQD, AvgDens, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN) :: NA,N,NZ,LW INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: ICNTL(40), SYM INTEGER, INTENT(INOUT) :: IFLAG INTEGER, INTENT(OUT) :: IERROR,NRORM,NIORM,IWFR INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, INTENT(OUT) :: LEN(N), IPE(N+1) INTEGER, INTENT(OUT) :: symmetry, & MedDens, NBQD, AvgDens INTEGER, INTENT(OUT) :: FLAG(N), IW(LW), IQ(N) INTEGER MP, MPG INTEGER I,K,J,N1,LAST,NDUP,K1,K2,L INTEGER NBERR, THRESH, IAO INTEGER NZOFFA, NDIAGA DOUBLE PRECISION RSYM INTRINSIC nint 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 MP = ICNTL(2) MPG= ICNTL(3) NIORM = 3*N NDIAGA = 0 IERROR = 0 IPE(1:N+1) = 0 DO K=1,NZ I = IRN(K) J = ICN(K) 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 IPE(J) = IPE(J) + 1 NIORM = NIORM + 1 ELSE NDIAGA = NDIAGA + 1 ENDIF ENDIF ENDDO NZOFFA = NIORM - 3*N 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 K=1,NZ I = IRN(K) J = ICN(K) 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(K,10).GT.3 .OR. mod(K,10).EQ.0 .OR. & (10.LE.K .AND. K.LE.20)) THEN WRITE (MP,'(I8,A,I8,A,I8,A)') & K,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K,10).EQ.1) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'st entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.2) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K,10).EQ.3) WRITE(MP,'(I8,A,I8,A,I8,A)') & K,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2*N IQ(1) = 1 N1 = N - 1 IF (N1.GT.0) THEN DO 110 I=1,N1 IQ(I+1) = IPE(I) + IQ(I) 110 CONTINUE 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 DO 200 K=1,NZ I = IRN(K) J = ICN(K) 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 IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF 200 CONTINUE NDUP = 0 DO 260 I=1,N K1 = IPE(I) K2 = IQ(I) -1 IF (K1.GT.K2) THEN LEN(I) = 0 IQ(I) = 0 ELSE DO 240 K=K1,K2 J = -IW(K) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1 IW(L) = 0 IW(K) = 0 ELSE IW(L) = I IW(K) = J FLAG(J) = I ENDIF 240 CONTINUE 250 IQ(I) = IQ(I) - IPE(I) IF (NDUP.EQ.0) LEN(I) = IQ(I) ENDIF 260 CONTINUE IF (NDUP.NE.0) THEN IWFR = 1 DO 280 I=1,N IF (IQ(I).EQ.0) THEN LEN(I) = 0 IPE(I) = IWFR GOTO 280 ENDIF K1 = IPE(I) K2 = K1 + IQ(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K=K1,K2 IF (IW(K).NE.0) THEN IW(IWFR) = IW(K) IWFR = IWFR + 1 ENDIF 270 CONTINUE LEN(I) = IWFR - L 280 CONTINUE ENDIF IPE(N+1) = IPE(N) + LEN(N) IWFR = IPE(N+1) IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2*NZOFFA - (IWFR-1))/ & dble(NZOFFA+NDIAGA) symmetry = nint (100.0D0*RSYM) IF (MPG .GT. 0) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ELSE symmetry = 100 ENDIF AvgDens = nint(dble(IWFR-1)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN IQ(1:N) = 0 DO I= 1, N K = max(LEN(I),1) IQ(K) = IQ(K) + 1 IF (K.GT.THRESH) NBQD = NBQD+1 ENDDO K = 0 MedDens = 0 DO WHILE (K .LT. (N/2)) MedDens = MedDens + 1 K = K+IQ(MedDens) ENDDO ELSE MedDens = AvgDens ENDIF IF (MPG .GT. 0) & write(MPG,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens IF (MP.GT.0 .AND. MPG.NE.MP) & write(MP,'(A,3I5)') & ' Density: NBdense, Average, Median =', & NBQD, AvgDens, MedDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE DMUMPS_623 SUBROUTINE DMUMPS_549(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_549 SUBROUTINE DMUMPS_548(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_548 mumps-4.10.0.dfsg/src/smumps_part4.F0000644000175300017530000071137611562233065017457 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE SMUMPS_246(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 & ) IMPLICIT NONE 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 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_748 EXTERNAL SMUMPS_748 INTEGER MUMPS_275, MUMPS_330 LOGICAL MUMPS_170 INTEGER MUMPS_52 EXTERNAL MUMPS_503, MUMPS_52 EXTERNAL MUMPS_275, MUMPS_330, & MUMPS_170 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)) 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 = dble(0.0E0) ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = dble(0.0E0) 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_275(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_246 ' 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_275(PROCNODE(STEP(INODE)),SLAVEF) & .EQ. MYID LEVEL = MUMPS_330(PROCNODE(STEP(INODE)),SLAVEF) INSSARBR = MUMPS_170(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_503(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_170( & 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_748( & 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_748( & 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 = NRLADU + int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU = NRLADU + int(NELIM,8)*int(NCB/NSLAVES_LOC,8) ENDIF NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) 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_246. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_275(PROCNODE(STEP(IFSON)),SLAVEF) & .EQ.MYID LEVELSON = MUMPS_330(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_246. 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_511(NFR, & NELIM, NELIM,0, & 1,OPS_NODE) ELSE CALL MUMPS_511(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_511(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 ) & ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN OPSA_LOC = OPSA_LOC + OPS_NODE / dble( SLAVEF ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(SLAVEF,8) IF (MASTER) & ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) 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_170(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_511(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_330(PROCNODE(STEP(IFATH)),SLAVEF) MASTERF= MUMPS_275(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_503( 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_246' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in SMUMPS_246 ' 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_246 RECURSIVE SUBROUTINE & SMUMPS_271( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 40 ) INTEGER(8) KEEP8(150) 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(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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(max(1,KEEP(14))) REAL DBLARR(max(1,KEEP(13))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.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, & STATUS( MPI_STATUS_SIZE ), ISON, PDEST_MASTER_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL INVERT INCLUDE 'mumps_headers.h' INTEGER MUMPS_275, MUMPS_330 EXTERNAL MUMPS_275, MUMPS_330 FPERE = KEEP(38) TYPE_SON = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( MUMPS_275( 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_271 ', 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_80( 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, .FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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 INVERT = .FALSE. ELSE INVERT = .TRUE. END IF CALL SMUMPS_80( 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_93(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_275(PROCNODE_STEPS(STEP(ISON)), SLAVEF) DO WHILE ( PTRIST(STEP(ISON)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & PDEST_MASTER_ISON, MAITRE_DESC_BANDE, & 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) RETURN ENDDO DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_271 ' 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 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_271", & IW(IOLDPS+XXS), "INODE=",INODE CALL MUMPS_ABORT() ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN INVERT = .FALSE. ELSE INVERT = .TRUE. END IF CALL SMUMPS_80( 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL SMUMPS_314( 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, TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL SMUMPS_44( MYID, SLAVEF, COMM ) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_271 SUBROUTINE SMUMPS_221(NFRONT,NASS,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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW INTEGER(8) :: LA REAL A(LA) REAL UU, SEUIL INTEGER IW(LIW) INTEGER(8) :: POSELT INTEGER IOLDPS INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INCLUDE 'mumps_headers.h' REAL SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, J3, JJ INTEGER(8) :: NFRONT8 REAL AMROW REAL RMAX REAL PIVNUL REAL FIXA, CSEUIL INTEGER NPIV,NASSW,IPIV INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW INTEGER SMUMPS_IXAMAX INTRINSIC max REAL, PARAMETER :: RZERO = 0.0E0 REAL, PARAMETER :: ZERO = 0.0E0 INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NFRONT8 = int(NFRONT,8) IF (KEEP(201).EQ.1) THEN CALL SMUMPS_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL SMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_680( 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 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF (UU.GT.RZERO) GO TO 340 IF (abs(A(APOS)).EQ.RZERO) GO TO 630 GO TO 380 340 AMROW = RZERO J1 = APOS J2 = APOS + int(- NPIV + NASS - 1,8) J = NASS -NPIV JMAX = SMUMPS_IXAMAX(J,A(J1),1) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW J1 = J2 + 1_8 J2 = APOS +int(- NPIV + NFRONT - 1 - KEEP(253),8) IF (J2.LT.J1) GO TO 370 DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF ( RMAX .LE. PIVNUL ) THEN KEEP(109) = KEEP(109)+1 ISW = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE+ & IW(IOLDPS+5+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)).GT. max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE. max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_762( & 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 + 5 + NPIVP1 + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + 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) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + 5 + NFRONT + NPIV + 1 +XSIZE ISWPS2 = IOLDPS + 5 + NFRONT + NPIV + JMAX +XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 WRITE(*,*) 'Detected a null pivot, INODE/NPIV=',INODE,NPIV GOTO 430 420 CONTINUE IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_680( 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_221 SUBROUTINE SMUMPS_220(NFRONT,NASS,N,INODE,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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,INOPV INTEGER(8) :: LA INTEGER KEEP(500) REAL DKEEP(30) REAL UU, SEUIL REAL A(LA) INTEGER IW(LIW) REAL AMROW REAL RMAX REAL SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NOFFW,NPIV,IPIV 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 SMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max REAL, PARAMETER :: RZERO = 0.0E0 NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL SMUMPS_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL SMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF DO 460 IPIV=NPIVP1,NASS APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = SMUMPS_IXAMAX(J3,A(J1),NFRONT) 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 (J3.EQ.0) GOTO 370 DO 360 J=1,J3 RMAX = max(abs(A(J1)),RMAX) J1 = J1 + NFRONT8 360 CONTINUE 370 IF (RMAX.EQ.RZERO) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)).GE.max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LT.max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_762( & 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 390 J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 390 CONTINUE 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 410 KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 410 CONTINUE 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_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_680( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE SMUMPS_220 SUBROUTINE SMUMPS_225(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_225 SUBROUTINE SMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA,IOLDPS, & POSELT,XSIZE) IMPLICIT NONE INTEGER NFRONT,N,INODE,LIW,XSIZE INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) REAL ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS INTEGER(8) :: NFRONT8, LPOS, IRWPOS INTEGER IOLDPS,NPIV,NEL INTEGER JROW INCLUDE 'mumps_headers.h' REAL, PARAMETER :: ONE = 1.0E0 NFRONT8= int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NEL = NFRONT - NPIV - 1 APOS = POSELT + int(NPIV,8) * NFRONT8 + int(NPIV,8) IF (NEL.EQ.0) GO TO 650 VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 340 JROW = 1,NEL A(LPOS) = VALPIV*A(LPOS) LPOS = LPOS + NFRONT8 340 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS+1_8 DO 440 JROW = 1,NEL IRWPOS = LPOS + 1_8 ALPHA = -A(LPOS) CALL saxpy(NEL,ALPHA,A(UUPOS),1,A(IRWPOS),1) LPOS = LPOS + NFRONT8 440 CONTINUE 650 RETURN END SUBROUTINE SMUMPS_229 SUBROUTINE SMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,N,LIW,INODE,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,KROW, XSIZE INTEGER NEL,ICOL,NEL2 INTEGER NPIVP1 REAL, PARAMETER :: ONE = 1.0E0 NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 DO 440 ICOL = 1,NEL IRWPOS = LPOS + 1_8 ALPHA = -A(LPOS) CALL saxpy(NEL2,ALPHA,A(UUPOS),1,A(IRWPOS),1) LPOS = LPOS + NFRONT8 440 CONTINUE RETURN END SUBROUTINE SMUMPS_228 SUBROUTINE SMUMPS_231(A,LA,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER(8) :: LA,POSELT REAL A(LA) INTEGER NFRONT, NPIV, NASS INTEGER(8) :: LPOS, LPOS1, LPOS2 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) 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_231 SUBROUTINE SMUMPS_642(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_688 & ( 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_642 SUBROUTINE SMUMPS_232(A,LA,NFRONT,NPIV,NASS,POSELT,LKJIB) INTEGER NFRONT, NPIV, NASS, LKJIB INTEGER (8) :: POSELT, LA REAL A(LA) INTEGER(8) :: POSELT_LOCAL, LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPBEG REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) POSELT_LOCAL = POSELT NEL1 = NASS - NPIV NPBEG = NPIV - LKJIB + 1 NEL11 = NFRONT - NPIV LPOS2 = POSELT_LOCAL + int(NPIV,8)*int(NFRONT,8) & + int(NPBEG - 1,8) POSELT_LOCAL = POSELT_LOCAL + int(NPBEG-1,8)*int(NFRONT,8) & + int(NPBEG-1,8) CALL strsm('L','L','N','N',LKJIB,NEL1,ONE,A(POSELT_LOCAL), & NFRONT,A(LPOS2),NFRONT) LPOS = LPOS2 + int(LKJIB,8) LPOS1 = POSELT_LOCAL + int(LKJIB,8) CALL sgemm('N','N',NEL11,NEL1,LKJIB,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE SMUMPS_232 SUBROUTINE SMUMPS_233(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT,XSIZE ) IMPLICIT NONE INTEGER NFRONT, NASS,N,LIW INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG,LKJIB, INODE, IBEG_BLOCK INTEGER(8) :: POSELT, LPOS, LPOS1, LPOS2, POSLOCAL INTEGER(8) :: IPOS, KPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1, NEL11 INTEGER LBP, HF INTEGER LBPT,I1,K1,II,ISWOP,LBP1 INTEGER LKJIT, XSIZE INCLUDE 'mumps_headers.h' REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) JROW2 = iabs(IW(IOLDPS+3+XSIZE)) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+XSIZE) +XSIZE NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+XSIZE)= min0(NPIV+LKJIB,NASS) ELSE IW(IOLDPS+3+XSIZE) = NASS ENDIF IBEG_BLOCK = NPIV + 1 NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 NEL11 = NFRONT - NPIV IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN LPOS2 = POSELT + int(JROW2,8)*NFRONT8 + & int(NPBEG - 1,8) POSLOCAL = POSELT + int(NPBEG-1,8)*NFRONT8 + int(NPBEG - 1,8) CALL strsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSLOCAL),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSLOCAL + int(LKJIW,8) CALL sgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF RETURN END SUBROUTINE SMUMPS_233 SUBROUTINE SMUMPS_236(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_236 SUBROUTINE SMUMPS_217(N, NZ, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NZ, NSCA INTEGER IRN(NZ), ICN(NZ) INTEGER ICNTL(40), INFO(40) REAL ASPK(NZ) REAL COLSCA(*), ROWSCA(*) INTEGER LWK, LWK_REAL REAL WK(LWK) REAL WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER IWNOR INTEGER I, K LOGICAL PROK REAL ONE PARAMETER( ONE = 1.0E0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROK = (MPG.GT.0) IF (PROK) WRITE(MPG,101) 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROK) & WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.2) THEN IF (PROK) & WRITE (MPG,*) ' SCALING BASED ON (MC29)' 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)' ELSEIF (NSCA.EQ.5) THEN IF (PROK) & WRITE (MPG,*) ' MC29 FOLLOWED BY ROW &COL SCALING' ELSEIF (NSCA.EQ.6) THEN IF (PROK) & WRITE (MPG,*) ' MC29 FOLLOWED BY COLUMN SCALING' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF ((NSCA.EQ.5).OR. & (NSCA.EQ.6)) THEN IF (NZ.GT.LWK) GOTO 400 DO 15 K=1,NZ WK(K) = ASPK(K) 15 CONTINUE ENDIF IF (5*N.GT.LWK_REAL) GOTO 410 IWNOR = 1 IF (NSCA.EQ.1) THEN CALL SMUMPS_238(N,NZ,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.2) THEN CALL SMUMPS_239(N,NZ,ASPK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) ELSEIF (NSCA.EQ.3) THEN CALL SMUMPS_241(N,NZ,ASPK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN CALL SMUMPS_287(N,NZ,IRN,ICN,ASPK, & WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.5) THEN CALL SMUMPS_239(N,NZ,WK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) CALL SMUMPS_241(N,NZ,WK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.6) THEN CALL SMUMPS_239(N,NZ,WK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) CALL SMUMPS_240(NSCA,N,NZ,IRN,ICN,WK, & WK_REAL(IWNOR+N),ROWSCA,MPG) CALL SMUMPS_241(N,NZ,WK,IRN,ICN, & WK_REAL(IWNOR), COLSCA, MPG) ENDIF GOTO 500 400 INFO(1) = -5 INFO(2) = NZ-LWK IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' 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_217 SUBROUTINE SMUMPS_287(N,NZ,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER N, NZ REAL VAL(NZ) REAL RNOR(N),CNOR(N) REAL COLSCA(N),ROWSCA(N) REAL CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ), ICN(NZ) REAL VDIAG INTEGER MPRINT INTEGER I,J,K 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 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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_287 SUBROUTINE SMUMPS_239(N,NZ,VAL,ROWIND,COLIND, & RNOR,CNOR,WNOR,MPRINT,MP, & NSCA) INTEGER N, NZ REAL VAL(NZ) REAL WNOR(5*N) REAL RNOR(N), CNOR(N) INTEGER COLIND(NZ),ROWIND(NZ) INTEGER J,I,K INTEGER MPRINT,MP,NSCA INTEGER IFAIL9 REAL ZERO PARAMETER( ZERO = 0.0E0) DO 15 I=1,N RNOR(I) = ZERO CNOR(I) = ZERO 15 CONTINUE CALL SMUMPS_216(N,N,NZ,VAL,ROWIND,COLIND, & RNOR,CNOR,WNOR, MP,IFAIL9) *CVD$ NODEPCHK *CVD$ VECTOR *CVD$ CONCUR DO 30 I=1,N CNOR(I) = exp(CNOR(I)) RNOR(I) = exp(RNOR(I)) 30 CONTINUE IF ((NSCA.EQ.5).OR.(NSCA.EQ.6)) THEN DO 100 K=1,NZ I = ROWIND(K) J = COLIND(K) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 100 VAL(K) = VAL(K) * CNOR(J) * RNOR(I) 100 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING USING MC29' RETURN END SUBROUTINE SMUMPS_239 SUBROUTINE SMUMPS_241(N,NZ,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER N,NZ REAL VAL(NZ) REAL CNOR(N) REAL COLSCA(N) INTEGER IRN(NZ), ICN(NZ) REAL VDIAG INTEGER MPRINT INTEGER I,J,K REAL ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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_241 SUBROUTINE SMUMPS_238(N,NZ,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER N, NZ REAL VAL(NZ) REAL ROWSCA(N),COLSCA(N) INTEGER IRN(NZ),ICN(NZ) REAL VDIAG INTEGER MPRINT,I,J,K INTRINSIC sqrt REAL ZERO, ONE PARAMETER(ZERO=0.0E0, ONE=1.0E0) DO 10 I=1,N ROWSCA(I) = ONE 10 CONTINUE DO 100 K=1,NZ I = IRN(K) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K) IF (I.EQ.J) THEN VDIAG = abs(VAL(K)) 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_238 SUBROUTINE SMUMPS_240(NSCA,N,NZ,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER N, NZ, NSCA INTEGER IRN(NZ), ICN(NZ) REAL VAL(NZ) REAL RNOR(N) REAL ROWSCA(N) REAL VDIAG INTEGER MPRINT INTEGER I,J,K REAL ZERO,ONE PARAMETER (ZERO=0.0E0, ONE=1.0E0) DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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 K=1,NZ I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K) = VAL(K) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE SMUMPS_240 SUBROUTINE SMUMPS_216(M,N,NE,A,IRN,ICN,R,C,W,LP,IFAIL) INTEGER M,N,NE REAL A(NE) INTEGER IRN(NE),ICN(NE) REAL R(M),C(N) REAL W(M*2+N*3) INTEGER LP,IFAIL INTRINSIC log,abs,min INTEGER MAXIT PARAMETER (MAXIT=100) REAL ONE REAL SMIN,ZERO PARAMETER (ONE=1.0E0,SMIN=0.1E0,ZERO=0.0E0) INTEGER I,I1,I2,I3,I4,I5,ITER,J,K REAL E,E1,EM,Q,Q1,QM,S,S1,SM,U,V IFAIL = 0 IF (M.LT.1 .OR. N.LT.1) THEN IFAIL = -1 GO TO 220 ELSE IF (NE.LE.0) THEN IFAIL = -2 GO TO 220 END IF I1 = 0 I2 = M I3 = M + N I4 = M + N*2 I5 = M + N*3 DO 10 I = 1,M R(I) = ZERO W(I1+I) = ZERO 10 CONTINUE DO 20 J = 1,N C(J) = ZERO W(I2+J) = ZERO W(I3+J) = ZERO W(I4+J) = ZERO 20 CONTINUE DO 30 K = 1,NE U = abs(A(K)) IF (U.EQ.ZERO) GO TO 30 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 30 U = log(U) W(I1+I) = W(I1+I) + ONE W(I2+J) = W(I2+J) + ONE R(I) = R(I) + U W(I3+J) = W(I3+J) + U 30 CONTINUE DO 40 I = 1,M IF (W(I1+I).EQ.ZERO) W(I1+I) = ONE R(I) = R(I)/W(I1+I) W(I5+I) = R(I) 40 CONTINUE DO 50 J = 1,N IF (W(I2+J).EQ.ZERO) W(I2+J) = ONE W(I3+J) = W(I3+J)/W(I2+J) 50 CONTINUE SM = SMIN*real(NE) DO 60 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 60 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 60 R(I) = R(I) - W(I3+J)/W(I1+I) 60 CONTINUE E = ZERO Q = ONE S = ZERO DO 70 I = 1,M S = S + W(I1+I)*R(I)**2 70 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 160 DO 150 ITER = 1,MAXIT DO 80 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 80 J = ICN(K) I = IRN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 80 C(J) = C(J) + R(I) 80 CONTINUE S1 = S S = ZERO DO 90 J = 1,N V = -C(J)/Q C(J) = V/W(I2+J) S = S + V*C(J) 90 CONTINUE E1 = E E = Q*S/S1 Q = ONE - E IF (abs(S).LE.abs(SM)) E = ZERO DO 100 I = 1,M R(I) = R(I)*E*W(I1+I) 100 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 180 EM = E*E1 DO 110 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 110 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 110 R(I) = R(I) + C(J) 110 CONTINUE S1 = S S = ZERO DO 120 I = 1,M V = -R(I)/Q R(I) = V/W(I1+I) S = S + V*R(I) 120 CONTINUE E1 = E E = Q*S/S1 Q1 = Q Q = ONE - E IF (abs(S).LE.abs(SM)) Q = ONE QM = Q*Q1 DO 130 J = 1,N W(I4+J) = (EM*W(I4+J)+C(J))/QM W(I3+J) = W(I3+J) + W(I4+J) 130 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 160 DO 140 J = 1,N C(J) = C(J)*E*W(I2+J) 140 CONTINUE 150 CONTINUE 160 DO 170 I = 1,M R(I) = R(I)*W(I1+I) 170 CONTINUE 180 DO 190 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 190 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 190 R(I) = R(I) + W(I3+J) 190 CONTINUE DO 200 I = 1,M R(I) = R(I)/W(I1+I) - W(I5+I) 200 CONTINUE DO 210 J = 1,N C(J) = -W(I3+J) 210 CONTINUE RETURN 220 IF (LP.GT.0) WRITE (LP,'(/A/A,I3)') & ' **** Error return from SMUMPS_216 ****',' IFAIL =',IFAIL END SUBROUTINE SMUMPS_216 SUBROUTINE SMUMPS_27( 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_207(id%A(1), & id%NZ, id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL SMUMPS_289(id%A(1), & id%NZ, 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_119(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL SMUMPS_135(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, 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%NZ_loc .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL SMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1) ) ELSE CALL SMUMPS_289(id%A_loc(1), & id%NZ_loc, 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_27 SUBROUTINE SMUMPS_693(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, M, 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 RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) REAL ROWSCA(M) REAL COLSCA(N) INTEGER ISZWRKRC REAL WRKRC(ISZWRKRC) REAL ONENORMERR,INFNORMERR INTEGER SYM, NB1, NB2, NB3 REAL EPS EXTERNAL SMUMPS_694,SMUMPS_687, & SMUMPS_670 INTEGER I IF(SYM.EQ.0) THEN CALL SMUMPS_694(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_687(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_693 SUBROUTINE SMUMPS_694(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, M, 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 RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) REAL ROWSCA(M) REAL COLSCA(N) INTEGER ISZWRKRC REAL WRKRC(ISZWRKRC) REAL ONENORMERR,INFNORMERR INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC 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 INTEGER NB1, NB2, NB3 REAL EPS INTEGER ITER, NZIND, IR, IC REAL ELM 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) EXTERNAL SMUMPS_654, & SMUMPS_672, & SMUMPS_674, & SMUMPS_662, & SMUMPS_743, & SMUMPS_745, & SMUMPS_660, & SMUMPS_670, & SMUMPS_671, & SMUMPS_657, & SMUMPS_656 INTEGER SMUMPS_743 INTEGER SMUMPS_745 REAL SMUMPS_737 REAL SMUMPS_738 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) 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 IF(OP == 1) THEN IF(NUMPROCS > 1) THEN CALL SMUMPS_654(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ) CALL SMUMPS_654(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ) CALL SMUMPS_672(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_672(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_662(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 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0 ENDIF RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL RESZ = RESZR + RESZC 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 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 CALL SMUMPS_660(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 IRNGHBPRCS = IMYCPTR+ INUMMYC IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1 OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM OCSNDRCVJA = OCSNDRCVIA + NUMPROCS + 1 REQUESTS = OCSNDRCVJA + OCSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL SMUMPS_674(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_674(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_670(ROWSCA, M, RZERO) CALL SMUMPS_670(COLSCA, N, RZERO) CALL SMUMPS_671(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE) CALL SMUMPS_671(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE) ELSE CALL SMUMPS_670(ROWSCA, M, RONE) CALL SMUMPS_670(COLSCA, N, RONE) ENDIF ITDRPTR = 1 ITDCPTR = ITDRPTR + M ISRRPTR = ITDCPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL ISRCPTR = OSRRPTR + ORSNDRCVVOL OSRCPTR = ISRCPTR + ICSNDRCVVOL IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1 ISRCPTR = ISRCPTR - 1 OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) IF(NUMPROCS > 1) THEN CALL SMUMPS_650(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) CALL SMUMPS_650(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) ELSE CALL SMUMPS_670(WRKRC(ITDRPTR),M, RZERO) CALL SMUMPS_670(WRKRC(ITDCPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1,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_657(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) CALL SMUMPS_657(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_737(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) INFERRCOL = SMUMPS_737(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL SMUMPS_665(COLSCA, WRKRC(ITDCPTR), & N, & IWRK(IMYCPTR),INUMMYC) CALL SMUMPS_665(ROWSCA, WRKRC(ITDRPTR), & M, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = SMUMPS_738(ROWSCA, & WRKRC(ITDRPTR), M) INFERRCOL = SMUMPS_738(COLSCA, & WRKRC(ITDCPTR), N) INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL SMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL SMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE IF((ITER .EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1,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_656(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) CALL SMUMPS_656(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_737(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) ONEERRCOL = SMUMPS_737(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_665(COLSCA, WRKRC(ITDCPTR), & N, & IWRK(IMYCPTR),INUMMYC) CALL SMUMPS_665(ROWSCA, WRKRC(ITDRPTR), & M, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = SMUMPS_738(ROWSCA, & WRKRC(ITDRPTR), M) ONEERRCOL = SMUMPS_738(COLSCA, & WRKRC(ITDCPTR), N) ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL SMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL SMUMPS_665(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) CALL SMUMPS_665(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) ELSE CALL SMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL SMUMPS_666(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 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_694 SUBROUTINE SMUMPS_687(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, 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) INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ISRRPTR, OSRRPTR REAL ONENORMERR,INFNORMERR INTEGER NB1, NB2, NB3 REAL EPS INTEGER ITER, NZIND, IR, IC REAL ELM INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) EXTERNAL SMUMPS_655, & SMUMPS_673, & SMUMPS_692, & SMUMPS_663, & SMUMPS_742, & SMUMPS_745, & SMUMPS_661, & SMUMPS_657, & SMUMPS_656, & SMUMPS_670, & SMUMPS_671 INTEGER SMUMPS_742 INTEGER SMUMPS_745 REAL SMUMPS_737 REAL SMUMPS_738 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) 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 CALL SMUMPS_655(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ) CALL SMUMPS_673(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc,JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL SMUMPS_663(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWRKSZ) INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZ = INTSZR + N + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0 ENDIF RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) INUMMYR = REGISTRE(9) IF(NUMPROCS > 1) THEN CALL SMUMPS_661(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-INUMMYR) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 REQUESTS = ORSNDRCVJA + ORSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL SMUMPS_692(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_670(SCA, N, RZERO) CALL SMUMPS_671(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE) ELSE CALL SMUMPS_670(SCA, N, RONE) ENDIF ITDRPTR = 1 ISRRPTR = ITDRPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) IF(NUMPROCS > 1) THEN CALL SMUMPS_650(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL SMUMPS_670(WRKRC(ITDRPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1,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_657(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_737(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_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = SMUMPS_738(SCA, & WRKRC(ITDRPTR), N) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL SMUMPS_666(SCA, WRKRC(ITDRPTR), N) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1,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,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_656(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_737(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = SMUMPS_738(SCA, & WRKRC(ITDRPTR), N) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_666(SCA, WRKRC(ITDRPTR), N) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL SMUMPS_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL SMUMPS_666(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_687 SUBROUTINE SMUMPS_654(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL SMUMPS_703 INTEGER MYID, NUMPROCS, COMM INTEGER NZ_loc, ISZ, IWSZ, OSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWSZ) INCLUDE 'mpif.h' INTEGER I INTEGER OP, IERROR INTEGER IR, IC IF(NUMPROCS.NE.1) THEN CALL MPI_OP_CREATE(SMUMPS_703, .TRUE., OP, IERROR) CALL SMUMPS_668(IWRK, 4*ISZ, ISZ) DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_654 SUBROUTINE SMUMPS_662(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, M, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER INUMMYR, INUMMYC INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC INUMMYR = 0 INUMMYC = 0 DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRK(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I=1,NZ_loc IC = JCN_loc(I) IR = IRN_loc(I) 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 RETURN END SUBROUTINE SMUMPS_662 SUBROUTINE SMUMPS_660(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, 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 INTEGER I, IR, IC, ITMP, MAXMN MAXMN = M IF(N > MAXMN) MAXMN = N DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_660 INTEGER FUNCTION SMUMPS_744(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL EPS INTEGER I, IID REAL RONE PARAMETER(RONE=1.0E0) SMUMPS_744 = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN SMUMPS_744 = 0 ENDIF ENDDO RETURN END FUNCTION SMUMPS_744 INTEGER FUNCTION SMUMPS_745(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL EPS INTEGER I REAL RONE PARAMETER(RONE=1.0E0) SMUMPS_745 = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN SMUMPS_745 = 0 ENDIF ENDDO RETURN END FUNCTION SMUMPS_745 INTEGER FUNCTION SMUMPS_743(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_744 INTEGER SMUMPS_744 INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = SMUMPS_744(DR, M, INDXR, INDXRSZ, EPS) MYRESC = SMUMPS_744(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) SMUMPS_743 = GLORES RETURN END FUNCTION SMUMPS_743 REAL FUNCTION SMUMPS_737(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) 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_737 = ERRMAX RETURN END FUNCTION SMUMPS_737 REAL FUNCTION SMUMPS_738(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL TMPD(DSZ) 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_738 = ERRMAX1 RETURN END FUNCTION SMUMPS_738 SUBROUTINE SMUMPS_665(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt 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_665 SUBROUTINE SMUMPS_666(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL TMPD(DSZ) INTRINSIC sqrt 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_666 SUBROUTINE SMUMPS_671(D, DSZ, INDX, INDXSZ, VAL) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL VAL INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO RETURN END SUBROUTINE SMUMPS_671 SUBROUTINE SMUMPS_702(D, DSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = 1.0E0/D(IIND) ENDDO RETURN END SUBROUTINE SMUMPS_702 SUBROUTINE SMUMPS_670(D, DSZ, VAL) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL VAL INTEGER I DO I=1,DSZ D(I) = VAL ENDDO RETURN END SUBROUTINE SMUMPS_670 SUBROUTINE SMUMPS_650(TMPD, TMPSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER TMPSZ,INDXSZ REAL TMPD(TMPSZ) INTEGER INDX(INDXSZ) INTEGER I REAL DZERO PARAMETER(DZERO=0.0E0) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO RETURN END SUBROUTINE SMUMPS_650 SUBROUTINE SMUMPS_703(INV, INOUTV, LEN, DTYPE) IMPLICIT NONE INTEGER LEN INTEGER INV(2*LEN) INTEGER INOUTV(2*LEN) INTEGER DTYPE INTEGER I INTEGER DIN, DINOUT, PIN, PINOUT DO I=1,2*LEN-1,2 DIN = INV(I) PIN = INV(I+1) DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_703 SUBROUTINE SMUMPS_668(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER IWSZ INTEGER IW(IWSZ) INTEGER IVAL INTEGER I DO I=1,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE SMUMPS_668 SUBROUTINE SMUMPS_704(MYID, NUMPROCS, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRKROW, IWRKCOL, IWSZR, IWSZC, COMM ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, M, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(M) INTEGER MYCOLINDICES(N) INTEGER INUMMYR, INUMMYC INTEGER IWSZR, IWSZC INTEGER IWRKROW(IWSZR) INTEGER IWRKCOL(IWSZC) INTEGER COMM INTEGER I, IR, IC, ITMP INUMMYR = 0 INUMMYC = 0 DO I=1,M IWRKROW(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRKROW(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRKROW(IR) .EQ. 0) THEN IWRKROW(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO ITMP = 1 DO I=1,M IF(IWRKROW(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO DO I=1,N IWRKCOL(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRKCOL(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRKCOL(IC) .EQ. 0) THEN IWRKCOL(IC)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDIF ENDDO ITMP = 1 DO I=1,N IF(IWRKCOL(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_704 SUBROUTINE SMUMPS_672(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ, OSZ INTEGER ISNDRCVNUM, ISNDRCVVOL INTEGER OSNDRCVNUM, OSNDRCVVOL INTEGER COMM INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWRKSZ) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INCLUDE 'mpif.h' INTEGER I INTEGER IIND, IIND2, PIND INTEGER IERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO DO I=1,NZ_loc IIND = INDX(I) IIND2 = OINDX(I) 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 IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 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_672 SUBROUTINE SMUMPS_674(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 MYID, NUMPROCS, NZ_loc, ISZ, ISNDVOL, OSNDVOL, OSZ INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) 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 INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR DO I=1,ISZ IWRK(I) = 0 ENDDO 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 DO I=1,NZ_loc IIND=INDX(I) IIND2 = OINDX(I) 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 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_674 SUBROUTINE SMUMPS_657(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 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 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 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_657 SUBROUTINE SMUMPS_656(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 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 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 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_656 SUBROUTINE SMUMPS_655(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL SMUMPS_703 INTEGER MYID, NUMPROCS, COMM INTEGER NZ_loc, ISZ, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWSZ) INCLUDE 'mpif.h' INTEGER I INTEGER OP, IERROR INTEGER IR, IC IF(NUMPROCS.NE.1) THEN CALL MPI_OP_CREATE(SMUMPS_703, .TRUE., OP, IERROR) CALL SMUMPS_668(IWRK, 4*ISZ, ISZ) DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_655 SUBROUTINE SMUMPS_673(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ INTEGER ISNDRCVNUM, ISNDRCVVOL INTEGER OSNDRCVNUM, OSNDRCVVOL INTEGER COMM INTEGER INDX(NZ_loc), OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWRKSZ) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INCLUDE 'mpif.h' INTEGER I INTEGER IIND, IIND2, PIND INTEGER IERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO DO I=1,NZ_loc IIND = INDX(I) IIND2 = OINDX(I) 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 IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I) 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 CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 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_673 SUBROUTINE SMUMPS_663(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER INUMMYR INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC INUMMYR = 0 DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 RETURN END SUBROUTINE SMUMPS_663 INTEGER FUNCTION SMUMPS_742(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_744 INTEGER SMUMPS_744 INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = SMUMPS_744(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) SMUMPS_742 = GLORES RETURN END FUNCTION SMUMPS_742 SUBROUTINE SMUMPS_661(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, N INTEGER INUMMYR, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC, ITMP, MAXMN MAXMN = N DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_661 SUBROUTINE SMUMPS_692(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, NZ_loc, ISZ, ISNDVOL, OSNDVOL INTEGER INDX(NZ_loc), OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) 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 INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR DO I=1,ISZ IWRK(I) = 0 ENDDO 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 DO I=1,NZ_loc IIND=INDX(I) IIND2 = OINDX(I) 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(I) 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 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_692 SUBROUTINE SMUMPS_628(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_628 SUBROUTINE SMUMPS_629 &(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_729( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE SMUMPS_629 SUBROUTINE SMUMPS_630(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_630 SUBROUTINE SMUMPS_631(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_631 SUBROUTINE SMUMPS_94(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE) 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) 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 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) RETURN 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_629(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_729(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_630(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_631(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_94" ENDIF IF (RBEGCONTIG > 0_8) GOTO 25 CALL SMUMPS_629 & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL SMUMPS_628(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL SMUMPS_627(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_627(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_729(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL SMUMPS_631(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_724(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_729( 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_94" 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 RETURN END SUBROUTINE SMUMPS_94 SUBROUTINE SMUMPS_632(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_729(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_632 SUBROUTINE SMUMPS_627(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_627" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in SMUMPS_627" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in SMUMPS_627",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_627 SUBROUTINE SMUMPS_700(BUFR,LBUFR, & LBUFR_BYTES, & root, N, IW, LIW, A, LA, & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, 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) 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_S(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 ), PTRAIW(N), PTRARW( N ) INTEGER INTARR(max(1,KEEP(14))) REAL DBLARR(max(1,KEEP(13))) INCLUDE 'mpif.h' INTEGER IERR 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_S( 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 ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_681(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL SMUMPS_580(IERR) ENDIF CALL SMUMPS_507( 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_500( & 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 ENDIF IF (KEEP(60) == 0) THEN CALL SMUMPS_284( 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, 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_S(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST_S(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_700' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_38( 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 CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) 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_700' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL SMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_38( 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_38( 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 CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) ENDIF RETURN END SUBROUTINE SMUMPS_700 SUBROUTINE SMUMPS_762(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_762 SUBROUTINE SMUMPS_761(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_761 SUBROUTINE SMUMPS_763(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_762(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_763 SUBROUTINE SMUMPS_764( & 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_771 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_771, & .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_764 SUBROUTINE SMUMPS_771(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE INTEGER, INTENT(IN) :: NEL, DATATYPE 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_762(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = real(TMPEXPINOUT) ENDDO RETURN END SUBROUTINE SMUMPS_771 SUBROUTINE SMUMPS_765(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE SMUMPS_765 SUBROUTINE SMUMPS_766(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER DETER=1.0E0/DETER NEXP=-NEXP RETURN END SUBROUTINE SMUMPS_766 SUBROUTINE SMUMPS_767(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_767 SUBROUTINE SMUMPS_224(NFRONT,NASS,IBEGKJI, LPIV, TIPIV, & 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER IBEGKJI, LPIV INTEGER TIPIV(LPIV) INTEGER(8) :: LA REAL A(LA) INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW REAL UU, SEUIL 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(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U REAL SWOP INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3_8 INTEGER(8) :: NFRONT8 INTEGER ILOC REAL ZERO PARAMETER( ZERO = 0.0E0 ) REAL RZERO, RMAX, AMROW, ONE REAL PIVNUL REAL FIXA, CSEUIL INTEGER NPIV,NASSW,IPIV INTEGER NPIVP1,JMAX,J3,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF INCLUDE 'mumps_headers.h' INTEGER SMUMPS_IXAMAX INTRINSIC max DATA RZERO /0.0E0/ DATA ONE /1.0E0/ INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER XSIZE PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL NFRONT8=int(NFRONT,8) 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_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL SMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ILOC = NPIVP1 - IBEGKJI + 1 TIPIV(ILOC) = ILOC NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_680( 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 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF (UU.GT.RZERO) GO TO 340 IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 340 AMROW = RZERO J1 = APOS J2 = APOS +int(- NPIV + NASS - 1,8) J3 = NASS -NPIV JMAX = SMUMPS_IXAMAX(J3,A(J1),1) JJ = int(JMAX,8) + J1 - 1_8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = J2 + 1_8 J2 = APOS +int(- NPIV + NFRONT - KEEP(253)- 1,8) IF (J2.LT.J1) GO TO 370 DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF (RMAX.LE.PIVNUL) THEN KEEP(109) = KEEP(109)+1 ISW = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6+KEEP(IXSZ)+ & IW(IOLDPS+5+KEEP(IXSZ))+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 - KEEP(253) - 1,8) DO JJ=J1,J2 A(JJ)= ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF IF (abs(A(IDIAG)).GT.max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE.max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258).NE.0) THEN CALL SMUMPS_762( 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_8 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3_8) A(J3_8) = SWOP J3_8 = J3_8 + 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) TIPIV(ILOC) = ILOC + JMAX - 1 J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,NASS 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 (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 WRITE(*,*) 'NIV2:Detected 0 pivot, INODE,NPIV=',INODE,NPIV GOTO 430 420 CONTINUE IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_680( 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_224 SUBROUTINE SMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & IW, LIW, & IOLDPS, POSELT, A, LA, LDA_FS, & IBEGKJI, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mpif.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEGKJI, 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) 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), & PTRARW(LPTRAR), PTRAIW(LPTRAR), & ND( KEEP(28) ), FRERE( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) 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(max(1,KEEP(13))) EXTERNAL SMUMPS_329 INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES 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_294 ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEGKJI + 1 NCOL = LDA_FS - IBEGKJI + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEGKJI-1,8) + & int(IBEGKJI - 1,8) IF (IBEGKJI > 0) THEN CALL MUMPS_511( LDA_FS, IBEGKJI-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_511( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL SMUMPS_190(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTBL)) ) THEN PDEST = IOLDPS + 6 + KEEP(IXSZ) IERR = -1 IF ( NPIV .NE. 0 ) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF DO WHILE (IERR .EQ.-1) CALL SMUMPS_65( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTBL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP(50), NB_BLOC_FAC, & COMM, IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF (MESSAGE_RECEIVED) POSELT = PTRAST(STEP(INODE)) 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 CALL MUMPS_731( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL SMUMPS_44( MYID, SLAVEF, COMM ) 500 RETURN END SUBROUTINE SMUMPS_294 SUBROUTINE SMUMPS_273( 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, & 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) 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_330 EXTERNAL MUMPS_330 IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_330(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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_273', & ' 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_507(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE SMUMPS_273 SUBROUTINE SMUMPS_363(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_275 INTEGER MUMPS_275 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_170,MUMPS_167 LOGICAL MUMPS_170,MUMPS_167 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_363",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_363' 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_363' 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_363' 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_363' 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_363' 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_363' 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_462(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_363' 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_170(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_170(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_170(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_170(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_462(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_462(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_462(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(*,*)'Probleme dans reorder!!!!' 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_462(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_511(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_167(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_170( & 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_511(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_170( & PROCNODE(STEP(INODE)),SLAVEF)))THEN CALL SMUMPS_462(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_363 SUBROUTINE SMUMPS_364(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_283,MUMPS_275 LOGICAL MUMPS_283 INTEGER MUMPS_275 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 INDICE(SLAVEF),ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_170,MUMPS_167 LOGICAL MUMPS_170,MUMPS_167 DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK 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 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_363",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)) RETURN 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_363' 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_363' 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_363' 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_363' 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_462(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_363' 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_167(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_283(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_167(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_511(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_167(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_283(PROCNODE(STEP(INODE)),SLAVEF))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_275(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_275(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_167(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_275(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_170(PROCNODE(STEP(INODE)), & SLAVEF))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_283(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) 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_364 RECURSIVE SUBROUTINE SMUMPS_462(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_462(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL SMUMPS_462(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_462 mumps-4.10.0.dfsg/src/zmumps_ooc_buffer.F0000644000175300017530000004466311562233070020537 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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 INTEGER IO_STRAT 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_689(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_689 SUBROUTINE ZMUMPS_707(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL ZMUMPS_696(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_689(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE ZMUMPS_707 SUBROUTINE ZMUMPS_675(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_707(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL ZMUMPS_707(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_675 SUBROUTINE ZMUMPS_696(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_677(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_677(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_696 SUBROUTINE ZMUMPS_669(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_731(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_686() ELSE CALL ZMUMPS_685() ENDIF RETURN END SUBROUTINE ZMUMPS_669 SUBROUTINE ZMUMPS_659() 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_659 SUBROUTINE ZMUMPS_685() 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_689(OOC_FCT_TYPE_LOC) END SUBROUTINE ZMUMPS_685 SUBROUTINE ZMUMPS_678(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_707(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_678 SUBROUTINE ZMUMPS_686() 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_689(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE ZMUMPS_686 SUBROUTINE ZMUMPS_706(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_696(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL ZMUMPS_689(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_706 SUBROUTINE ZMUMPS_709 (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_709 SUBROUTINE ZMUMPS_653( 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_653: 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_707(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL ZMUMPS_706(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'ZMUMPS_653: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL ZMUMPS_709 (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_653 END MODULE ZMUMPS_OOC_BUFFER mumps-4.10.0.dfsg/src/smumps_part6.F0000644000175300017530000045777611562233065017474 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE SMUMPS_324(A, LDA, NPIV, NBROW, K50 ) IMPLICIT NONE INTEGER LDA, NPIV, NBROW, K50 REAL A(int(LDA,8)*int(NBROW+NPIV,8)) 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_324 SUBROUTINE SMUMPS_651(A, LDA, NPIV, NCONTIG ) IMPLICIT NONE INTEGER NCONTIG, NPIV, LDA REAL A(NCONTIG*LDA) 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_651 SUBROUTINE SMUMPS_652( 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(ALLOW_NON_INIT) 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(ALLOW_NON_INIT) 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_652 SUBROUTINE SMUMPS_705( 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(ALLOW_NON_INIT) 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) 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(ALLOW_NON_INIT) IF (.NOT. COMPRESSCB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_705 SUBROUTINE SMUMPS_140( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, & UU, NNEG, NPVW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS ) USE SMUMPS_OOC IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, 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(30) INTEGER INOPV, IFINB, NFRONT, NPIV, NBOLKJ, & NBTLKJ,IBEG_BLOCK INTEGER NASS, NEL1, IFLAG_OOC INTEGER :: LDA REAL UUTEMP INCLUDE 'mumps_headers.h' EXTERNAL SMUMPS_222, SMUMPS_234, & SMUMPS_230, SMUMPS_226, & SMUMPS_237 LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVSIZ,IWPOSP2 INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY LOGICAL POSTPONE_COL_UPDATE, IS_MAXFROMM_AVAIL REAL MAXFROMM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L INTEGER PP_LastPIVRPTRFilled IS_MAXFROMM_AVAIL = .FALSE. 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 POSTPONE_COL_UPDATE = (UUTEMP == 0.0E0 .AND. KEEP(201).NE.1) IBEG_BLOCK = 1 NFRONT = IW(IOLDPS+KEEP(IXSZ)) LDA = NFRONT NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IF (KEEP(201).EQ.1) THEN IDUMMY = -8765 CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L 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+KEEP(IXSZ): & IOLDPS+5+NFRONT+KEEP(IXSZ)+NFRONT) ENDIF IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) UUTEMP = UU 50 CONTINUE CALL SMUMPS_222(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & INOPV, NNEG, IFLAG,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, KEEP(IXSZ), & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL) 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+KEEP(IXSZ))+6+KEEP(IXSZ) & +IW(IOLDPS+5+KEEP(IXSZ)) PIVNUL_LIST(KEEP(109)) = IW(IWPOSP2) ENDIF ENDIF IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF CALL SMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, POSTPONE_COL_UPDATE, & ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG) GOTO 500 END IF IF (INOPV.EQ.2) THEN CALL SMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), & POSTPONE_COL_UPDATE, & KEEP,KEEP8) GOTO 50 ENDIF NPVW = NPVW + PIVSIZ IF (NASS.LE.1) THEN CALL SMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 GO TO 500 ENDIF CALL SMUMPS_226(IBEG_BLOCK, & NFRONT, NASS, N,INODE,IW,LIW,A,LA, & LDA, POSTPONE_COL_UPDATE, IOLDPS, & POSELT,IFINB, & NBTLKJ,PIVSIZ, KEEP(IXSZ),MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0E0), & KEEP(253) ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6 IW(IWPOSP2+NFRONT+KEEP(IXSZ)) = -IW(IWPOSP2+NFRONT+KEEP(IXSZ)) ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ IF (IFINB.EQ.0) GOTO 50 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NEL1 = NASS - NPIV IF (KEEP(201).EQ.1) THEN IF (IFINB.EQ.-1) THEN MonBloc%Last = .TRUE. ELSE MonBloc%Last = .FALSE. ENDIF MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_688( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG .LT. 0 ) RETURN ENDIF CALL SMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), & POSTPONE_COL_UPDATE, & KEEP,KEEP8) IF (IFINB.EQ.-1) THEN CALL SMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG) & GOTO 500 ENDIF GO TO 50 500 CONTINUE IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) LAST_CALL=.TRUE. CALL SMUMPS_688 & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC IF (IFLAG < 0 ) RETURN CALL SMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF RETURN END SUBROUTINE SMUMPS_140 SUBROUTINE SMUMPS_222 & (NFRONT,NASS,N,INODE,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) #if defined (PROFILE_BLAS_ASS_G) USE SMUMPS_LOAD #endif USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV, & IOLDPS, NNEG 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(30) 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 REAL RMAX,AMAX,TMAX,TOL REAL MAXPIV REAL PIVNUL REAL FIXA, CSEUIL REAL PIVOT,DETPIV PARAMETER(TOL = 1.0E-20) 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,NASSW,IPIV INTEGER NPIVP1,K 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) IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL SMUMPS_667(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 NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL SMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF GO TO 420 ENDIF AMAX = RZERO JMAX = 0 IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM > PIVNUL .AND. abs(PIVOT) > TOL) THEN IF ( abs(PIVOT) .GT. max(UULOC*MAXFROMM,SEUIL) ) THEN IF (PIVOT .LT. RZERO) NNEG = NNEG+1 IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, NASSW - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 IF ( (NFRONT - KEEP(253) - NASSW).GE.300 ) THEN OMP_FLAG = .TRUE. ELSE OMP_FLAG = .FALSE. ENDIF DO J=1, NFRONT - KEEP(253) - NASSW J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO 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, NASSW - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,NFRONT - NASSW A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN IF(SEUIL .GT. epsilon(SEUIL)) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL NNEG = NNEG+1 ENDIF PIVOT = A(POSPV1) KEEP(98) = KEEP(98)+1 GO TO 415 ENDIF ENDIF ENDIF IF (max(AMAX,abs(PIVOT)).LE.TOL) GO TO 460 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN IF (PIVOT .LT. ZERO) NNEG = NNEG+1 IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (AMAX.LE.TOL) GO TO 460 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 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 = (NFRONT-JMAX-KEEP(253). GE. 300) DO K = 1, NFRONT - JMAX - KEEP(253) JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 OMP_FLAG = (NFRONT-JMAX-KEEP(253). GE. 300) DO K = 1, NFRONT-JMAX-KEEP(253) JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO 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 ) GOTO 460 ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_762(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 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) THEN GOTO 416 ENDIF CALL SMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDA, NFRONT, 1, KEEP(219), KEEP(50), & KEEP(IXSZ)) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL SMUMPS_680( 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 (NASSW.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_222 SUBROUTINE SMUMPS_680( 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_680!" 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_680 SUBROUTINE SMUMPS_226(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW, & A,LA,LDA, POSTPONE_COL_UPDATE, & IOLDPS,POSELT,IFINB,LKJIB,PIVSIZ,XSIZE, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & KEEP253) IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB, & NPBEG, IBEG_BLOCK INTEGER LDA INTEGER(8) :: LA INTEGER(8) :: NFRONT8 REAL A(LA) LOGICAL POSTPONE_COL_UPDATE INTEGER IW(LIW) REAL VALPIV INTEGER(8) :: POSELT REAL, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, INTENT(in) :: KEEP253 REAL :: MAXFROMMTMP INTEGER IOLDPS, NCB1 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NPIV,JROW2 INTEGER NEL2,NEL INTEGER XSIZE REAL ONE, ZERO 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 = IW(IOLDPS+1+XSIZE) NPIV_NEW = NPIV + PIVSIZ NEL = NFRONT - NPIV_NEW IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. JROW2 = IW(IOLDPS+3+XSIZE) NPBEG = IBEG_BLOCK NEL2 = JROW2 - NPIV_NEW IF (NEL2.EQ.0) THEN IF (JROW2.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) A(APOS) = VALPIV 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 (POSTPONE_COL_UPDATE) THEN NCB1 = NASS - JROW2 ELSE NCB1 = NFRONT - JROW2 ENDIF IF (.NOT. IS_MAX_USEFUL) THEN 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 ELSE MAXFROMMTMP=0.0E0 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 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 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) A(POSPV2) = A(POSPV1)/DETPIV A(POSPV1) = SWOP/DETPIV A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL scopy(NFRONT-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL scopy(NFRONT-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 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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 = JROW2+1,NFRONT K1 = JJ K2 = JJ+1_8 MULT1 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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_226 SUBROUTINE SMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT) IMPLICIT NONE INTEGER NFRONT,N,INODE,LIW INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) REAL VALPIV INTEGER (8) :: APOS, POSELT, LPOS, NFRONT8 INTEGER IOLDPS,NEL INTEGER JROW REAL, PARAMETER :: ONE = 1.0E0 APOS = POSELT VALPIV = ONE/A(APOS) A(APOS) = VALPIV NEL = NFRONT - 1 IF (NEL.EQ.0) GO TO 500 NFRONT8 = int(NFRONT,8) LPOS = APOS + NFRONT8 CALL SMUMPS_XSYR('U',NEL, -VALPIV, & A(LPOS), NFRONT, A(LPOS+1_8), NFRONT) DO JROW = 1,NEL A(LPOS) = VALPIV*A(LPOS) LPOS = LPOS + NFRONT8 END DO 500 CONTINUE RETURN END SUBROUTINE SMUMPS_230 SUBROUTINE SMUMPS_234(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT, & POSTPONE_COL_UPDATE, & KEEP,KEEP8 ) IMPLICIT NONE INTEGER NFRONT, NASS,N,LIW, IBEG_BLOCK INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER(8) :: LDA8 INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1, NEL11 INTEGER LBP, HF INTEGER(8) :: LPOS,UPOS,APOS INTEGER LKJIT INTEGER LKJIBOLD, IROW INTEGER I, Block INTEGER BLSIZE LOGICAL POSTPONE_COL_UPDATE REAL ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=1.0E0, ALPHA=-1.0E0) LDA8 = int(LDA,8) LKJIBOLD = LKJIB NPIV = IW(IOLDPS+1+KEEP(IXSZ)) JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 NEL11 = NFRONT - NPIV IF ( LKJIW .NE. LKJIB ) THEN NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) LKJIB = min0(LKJIB, NASS - NPIV) ELSE LKJIB = NASS - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = NASS ENDIF IBEG_BLOCK = NPIV + 1 ELSEIF (JROW2.LT.NASS) THEN IBEG_BLOCK = NPIV + 1 IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) LKJIB = min0(LKJIB,NASS-NPIV) ENDIF IF (LKJIW.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF ( NASS - JROW2 > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NASS - JROW2 END IF IF ( NASS - JROW2 .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int(IROW - 1,8) APOS = POSELT + int(IROW - 1,8) * LDA8 + int(JROW2,8) CALL sgemm( 'N','N', IROW + Block - JROW2 - 1, Block, LKJIW, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ENDDO #else DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL sgemm( 'N','N', Block, NASS - IROW + 1, LKJIW, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF LPOS = POSELT + int(NASS,8)*LDA8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG-1,8) * LDA8 + int(JROW2,8) APOS = POSELT + int(NASS,8)*LDA8 + int(JROW2,8) IF ( .NOT. POSTPONE_COL_UPDATE ) THEN CALL sgemm('N', 'N', NEL1, NFRONT-NASS, LKJIW, ALPHA, & A(UPOS), LDA, A(LPOS), LDA, ONE, & A(APOS), LDA) END IF ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_234 SUBROUTINE SMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, NASS, & LDA, NFRONT, LEVEL, K219, K50, XSIZE ) 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 ) INCLUDE 'mumps_headers.h' 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 CALL sswap( NPIVP1 - 1, & A( POSELT + int(NPIVP1-1,8) ), LDA, & A( POSELT + int(IPIV-1,8) ), LDA ) END IF CALL sswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL sswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP CALL sswap( NASS - IPIV, A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF ( LEVEL .eq. 1 ) THEN CALL sswap( NFRONT - NASS, & A( APOS + int(NASS-IPIV+1,8) * LDA8 ), LDA, & A( IDIAG + int(NASS-IPIV+1,8) * LDA8 ), LDA ) END IF 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_319 SUBROUTINE SMUMPS_237(NFRONT,NASS,N,INODE, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG & ) USE SMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,N,INODE,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 INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, I, IROWEND INTEGER I2, I2END, Block2 REAL ONE, ALPHA, BETA, ZERO PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO=0.0E0) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(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 DO I = 1, NPIV CALL scopy( Block, A( LPOS+int(I-1,8) ), LDA, & A( UPOS+int(I-1,8)*LDA8 ), 1 ) CALL sscal( Block, A(POSELT+(LDA8+1_8)*int(I-1,8)), & A( LPOS + int(I - 1,8) ), LDA ) 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_688( & 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_237 SUBROUTINE SMUMPS_320( 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_327( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL SMUMPS_326( & 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_293( 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_281( 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_320 SUBROUTINE SMUMPS_293( 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_293 SUBROUTINE SMUMPS_281( 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_281 SUBROUTINE SMUMPS_327( 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_327 SUBROUTINE SMUMPS_326( 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_326 RECURSIVE SUBROUTINE SMUMPS_274( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD USE SMUMPS_OOC IMPLICIT NONE INCLUDE 'smumps_root.h' INCLUDE 'mumps_headers.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 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 PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 REAL DBLARR( max(1,KEEP(13)) ) 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 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL 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 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 MUMPS_275 EXTERNAL MUMPS_275 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 FPERE = -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 ) LAELL = int(NPIV,8) * int(NCOL,8) 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_731(LAELL-LRLUS, IERROR) IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN SMUMPS_274, & REAL WORKSPACE TOO SMALL" GOTO 700 END IF CALL SMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731(LAELL-LRLUS,IERROR) GOTO 700 END IF IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE IN SMUMPS_274, & INTEGER WORKSPACE TOO SMALL" IFLAG = -8 IERROR = IWPOS + NPIV - 1 - IWPOSCB GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL ENDIF KEEP8(67) = min(LRLUS, KEEP8(67)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) IF ( NPIV.GT.0 ) THEN IPIV = IWPOS IWPOS = IWPOS + NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, MPI_REAL, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) THEN DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF DO WHILE ( NBPROCFILS(STEP(INODE)) .NE. 0 ) BLOCKING = .TRUE. SET_IRECV=.FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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)) 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 ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN SMUMPS_274" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF 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_274" 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 CALL strsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), NCOL, & A(POSELT+int(NPIV1,8)), NCOL1 ) 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 LPOS = POSELT + int(NPIV1,8) DPOS = POSBLOCFACTO I = 1 DO IF(I .GT. NPIV) EXIT IF(IW(IPIV+I-1) .GT. 0) THEN CALL sscal( NROW1, A(DPOS), A(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(NCOL + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(NCOL + 1,8) OFFDAG = POSPV1+1_8 LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A(POSPV1)*A(LPOS1)+A(OFFDAG)*A(LPOS1+1_8) MULT2 = A(OFFDAG)*A(LPOS1)+A(POSPV2)*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(NCOL + 1,8) I = I+2 ENDIF ENDDO ENDIF 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 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) LAST_CALL=.FALSE. CALL SMUMPS_688( STRAT, TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN 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 FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * NCOL - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL SMUMPS_190( 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)) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL IWPOS = IWPOS - NPIV CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 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_64( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, IERR ) IF (IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & SMUMPS_274" 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_274" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( NPIV .NE. 0 ) DEALLOCATE( UIP21K ) IOLDPS = PTRIST(STEP(INODE)) IF (LASTBL) THEN IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) - & TO_UPDATE_CPT_END 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_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL SMUMPS_62( INODE, DEST, END_NIV2_LDLT, & COMM, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF END IF IF (LASTBL) THEN IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN CALL SMUMPS_759( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE SMUMPS_274 RECURSIVE SUBROUTINE SMUMPS_759( & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE SMUMPS_LOAD 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) 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_S(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) REAL A( LA ) 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) INTEGER INTARR( max(1,KEEP(14)) ) REAL DBLARR( max(1,KEEP(13)) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 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 (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+XXS)=S_ALL IF (KEEP(214).EQ.1) THEN CALL SMUMPS_314( 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, 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 CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) ENDIF ENDIF IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN CALL SMUMPS_627(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_80( 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_S, COMP, IFLAG, IERROR, NBPROCFILS, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, .FALSE., ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL SMUMPS_314( 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, ITYPE2 & ) ENDIF CALL SMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL SMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP & ) 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_628( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) IF (KEEP(216).EQ.2) THEN CALL SMUMPS_627(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 RETURN END SUBROUTINE SMUMPS_759 SUBROUTINE SMUMPS_141( 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 ) USE SMUMPS_OOC IMPLICIT NONE INCLUDE 'smumps_root.h' INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW INTEGER(8) :: LA REAL A( LA ) REAL UU, SEUIL TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, SLAVEF, & IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER ICNTL(40), KEEP(500) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IW( LIW ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), ITLOC(N+KEEP(253)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER PTRARW(LPTRAR), PTRAIW(LPTRAR), ND( KEEP(28) ) INTEGER FRERE(KEEP(28)), FILS(N) INTEGER INTARR(max(1,KEEP(14))) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), & PTLUST_S(KEEP(28)), & & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), NBPROCFILS(KEEP(28)), & PROCNODE_STEPS(KEEP(28)), STEP(N) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(max(1,KEEP(13))) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INTEGER(8) :: POSELT INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, NBTLKJ INTEGER NASS, IEND, IOLDPS, LDAFS,allocok, IBEG_BLOCK LOGICAL LASTBL LOGICAL RESET_TO_ONE, TO_UPDATE INTEGER K109_ON_ENTRY INTEGER I,J,JJ,K,IDEB REAL UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled EXTERNAL SMUMPS_223, SMUMPS_235, & SMUMPS_227, SMUMPS_294, & SMUMPS_44 LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVSIZ,IWPOSPIV REAL ONE PARAMETER (ONE = 1.0E0) INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0E0)) IF (RESET_TO_ONE) THEN K109_ON_ENTRY = KEEP(109) ENDIF IBEG_BLOCK=1 NB_BLOC_FAC = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST( STEP( INODE )) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) LDAFS = NASS IF (NASS .GT. KEEP(3)) THEN NBOLKJ = min( KEEP(6), NASS ) ELSE NBOLKJ = min( KEEP(5), NASS ) ENDIF NBTLKJ = NBOLKJ IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) IF (KEEP(201).EQ.1) THEN IDUMMY = -9876 CALL MUMPS_729(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+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ)) & :IOLDPS+5+2*NFRONT+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))) ENDIF ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, & ' integers' IFLAG=-13 IERROR=NASS GO TO 490 END IF 50 CONTINUE IBEGKJI = IBEG_BLOCK CALL SMUMPS_223( & NFRONT,NASS,IBEGKJI, 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) 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+KEEP(IXSZ))+6 & +IW(IOLDPS+5+KEEP(IXSZ)) PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+KEEP(IXSZ)) ENDIF ENDIF IF(INOPV.EQ. 1 .AND. STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF IF (INOPV.GE.1) THEN LASTBL = (INOPV.EQ.1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL SMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEGKJI, IEND, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (INOPV.EQ.1) GO TO 500 IF (INOPV.EQ.2) THEN CALL SMUMPS_235(IBEG_BLOCK, & NASS,N,INODE,IW,LIW,A,LA, & LDAFS, & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP,KEEP8) GOTO 50 ENDIF NPVW = NPVW + PIVSIZ IF (NASS.LE.1) THEN IFINB = -1 IF (NASS == 1) A(POSELT)=ONE/A(POSELT) ELSE CALL SMUMPS_227(IBEG_BLOCK, & NASS, N,INODE,IW,LIW,A,LA, & LDAFS, IOLDPS,POSELT,IFINB, & NBTLKJ,KEEP(4),PIVSIZ,KEEP(IXSZ)) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+1+KEEP(IXSZ))+6+ & IW(IOLDPS+5+KEEP(IXSZ)) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF ENDIF IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ IF (IFINB.EQ.0) GOTO 50 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN LASTBL = (IFINB.EQ.-1) IEND = IW(IOLDPS+1+KEEP(IXSZ)) CALL SMUMPS_294(COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEGKJI, IEND, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IF (IFINB.EQ.(-1)) GOTO 500 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) IF (KEEP(201).EQ.1) THEN IF (.NOT.RESET_TO_ONE.OR.K109_ON_ENTRY.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_688( & 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 CALL SMUMPS_235(IBEG_BLOCK, & NASS,N,INODE,IW,LIW,A,LA, & LDAFS, & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP,KEEP8) IF (KEEP(201).EQ.1) THEN IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 JJ= IDEB TO_UPDATE=.FALSE. DO K = K109_ON_ENTRY+1, KEEP(109) I = PIVNUL_LIST(K) DO J=JJ,JJ+NASS IF (IW(J).EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN JJ= J J = J-IDEB+1 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE TO_UPDATE=.FALSE. ELSE IF (ICNTL(1).GT.0) THEN write(ICNTL(1),*) ' Internal error related ', & 'to null pivot row detection' ENDIF EXIT ENDIF ENDDO ENDIF K109_ON_ENTRY = KEEP(109) MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_688( & 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 GO TO 50 490 CONTINUE CALL SMUMPS_44( MYID, SLAVEF, COMM ) 500 CONTINUE IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 JJ= IDEB TO_UPDATE=.FALSE. DO K = K109_ON_ENTRY+1, KEEP(109) I = PIVNUL_LIST(K) DO J=JJ,JJ+NASS IF (IW(J).EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN JJ= J J = J-IDEB+1 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE TO_UPDATE=.FALSE. ELSE IF (ICNTL(1).GT.0) THEN write(ICNTL(1),*) ' Internal error related ', & 'to null pivot row detection' ENDIF EXIT ENDIF ENDDO ENDIF IF (KEEP(201).EQ.1) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) LAST_CALL = .TRUE. CALL SMUMPS_688 & ( STRAT, 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 CALL SMUMPS_644 (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE SMUMPS_141 SUBROUTINE SMUMPS_223( NFRONT, NASS, & IBEGKJI, 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV INTEGER NASS2, IBEGKJI, NNEG INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV 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(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX REAL RMAX,AMAX,TMAX,TOL REAL MAXPIV REAL PIVOT,DETPIV PARAMETER(TOL = 1.0E-20) INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK 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,NASSW,IPIV INTEGER NPIVP1,ILOC,K,J INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L 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_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEGKJI + 1 TIPIV( ILOC ) = ILOC NASSW = iabs(IW(IOLDPS+3+KEEP(IXSZ))) 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 SMUMPS_762( A(APOS), DKEEP(6), KEEP(259) ) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL SMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF GO TO 420 ENDIF AMAX = RZERO 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, NASSW - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = max(abs(A(J1)),AMAX) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO IF (KEEP(219).NE.0) THEN RMAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX = RZERO ENDIF DO J=1,NASS - NASSW RMAX = max(abs(A(J1)),RMAX) J1 = J1 + LDAFS8 ENDDO 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, NASSW - IPIV A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO DO J=1,NASS - NASSW A(J1) = ZERO J1 = J1 + LDAFS8 ENDDO VALTMP = max(1.0E10*RMAX, sqrt(huge(RMAX))/1.0E8) A(POSPV1) = VALTMP ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN IF(SEUIL .GT. epsilon(SEUIL)) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = CSEUIL ELSE A(POSPV1) = -CSEUIL NNEG = NNEG+1 ENDIF PIVOT = A(POSPV1) WRITE(*,*) 'WARNING matrix may be singular' KEEP(98) = KEEP(98)+1 GO TO 415 ENDIF ENDIF ENDIF IF (max(AMAX,abs(PIVOT)) .LE. TOL) GOTO 460 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN IF (A(POSPV1).LT.RZERO) NNEG = NNEG+1 IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) ENDIF GO TO 415 END IF IF (AMAX.LE.TOL) GO TO 460 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 + LDAFS8 DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDAFS8 ENDDO 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 IF (KEEP(219).NE.0) THEN TMAX = max(SEUIL/UULOC,real(A(APOSMAX+int(JMAX,8)))) ELSE TMAX = SEUIL/UULOC ENDIF IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+int(NASS,8) IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+int(NASS,8) TMAX=max(TMAX,abs(A(JJ))) ENDDO 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 ) GOTO 460 ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV)) GO TO 460 IF (KEEP(258).NE.0) THEN CALL SMUMPS_762(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 DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEGKJI + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEGKJI + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEGKJI + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF CALL SMUMPS_319( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, KEEP(219), KEEP(50), & KEEP(IXSZ)) 416 CONTINUE IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN CALL SMUMPS_680( 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 (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE RETURN END SUBROUTINE SMUMPS_223 SUBROUTINE SMUMPS_235( & IBEG_BLOCK, & NASS, N, INODE, & IW, LIW, A, LA, & LDAFS, & IOLDPS, POSELT, & LKJIB_ORIG, LKJIB, LKJIT, KEEP,KEEP8 ) IMPLICIT NONE INTEGER NASS,N,LIW INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER (8) :: POSELT INTEGER (8) :: LDAFS8 INTEGER LDAFS, IBEG_BLOCK INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1 INTEGER HF INTEGER(8) :: LPOS,UPOS,APOS INTEGER LKJIT INTEGER LKJIBOLD, IROW INTEGER J, Block INTEGER BLSIZE REAL ONE, ALPHA PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) LKJIBOLD = LKJIB NPIV = IW(IOLDPS+1+KEEP(IXSZ)) JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 IF ( LKJIW .NE. LKJIB ) THEN NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) LKJIB = min0(LKJIB, NASS - NPIV) ELSE LKJIB = NASS - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = NASS ENDIF ELSEIF (JROW2.LT.NASS) THEN IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) ENDIF IBEG_BLOCK = NPIV + 1 IF (LKJIW.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF ( NASS - JROW2 > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NASS - JROW2 END IF IF ( NASS - JROW2 .GT. 0 ) THEN DO IROW = JROW2+1, NASS, BLSIZE Block = min( BLSIZE, NASS - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDAFS8 + int(NPBEG - 1,8) UPOS = POSELT + int(NPBEG - 1,8) * LDAFS8 + int(IROW - 1,8) APOS = POSELT + int(IROW-1,8) * LDAFS8 + int(IROW - 1,8) DO J=1, Block CALL sgemv( 'T', LKJIW, Block - J + 1, ALPHA, & A( LPOS ), LDAFS, A( UPOS ), LDAFS, & ONE, A( APOS ), LDAFS ) LPOS = LPOS + LDAFS8 APOS = APOS + LDAFS8 + 1_8 UPOS = UPOS + 1_8 END DO LPOS = POSELT + int(IROW-1+Block,8) * LDAFS8 & + int(NPBEG-1,8) UPOS = POSELT + int(NPBEG-1,8) * LDAFS8 + int(IROW-1,8) APOS = POSELT + int( IROW - 1 + Block,8 ) * LDAFS8 & + int(IROW - 1,8) CALL sgemm( 'N','N', Block, NASS - IROW + 1 - Block, LKJIW, & ALPHA, A( UPOS ), LDAFS, & A( LPOS ), LDAFS, ONE, A( APOS ), LDAFS ) END DO END IF END IF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_235 SUBROUTINE SMUMPS_227 & ( IBEG_BLOCK, NASS, N, INODE, IW, LIW, & A, LA, LDAFS, & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,PIVSIZ, & XSIZE) IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER :: LIW REAL A(LA) INTEGER IW(LIW) REAL VALPIV INTEGER IOLDPS, NCB1 INTEGER LKJIT, IBEG_BLOCK INTEGER NPIV,JROW2 INTEGER(8) :: APOS INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NASS,N,INODE,IFINB,LKJIB,LDAFS, & NPBEG INTEGER NEL2 INTEGER XSIZE REAL ONE, ALPHA REAL ZERO INTEGER PIVSIZ,NPIV_NEW INTEGER(8) :: IBEG, IEND, IROW INTEGER :: J2 REAL SWOP,DETPIV,MULT1,MULT2 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO=0.0E0) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV = IW(IOLDPS+1+XSIZE) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) ENDIF JROW2 = IW(IOLDPS+3+XSIZE) NPBEG = IBEG_BLOCK NEL2 = JROW2 - NPIV_NEW IF (NEL2.EQ.0) THEN IF (JROW2.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) A(APOS) = VALPIV LPOS = APOS + LDAFS8 CALL scopy(NASS-NPIV_NEW, A(LPOS), LDAFS, A(APOS+1_8), 1) CALL SMUMPS_XSYR('U', NEL2, -VALPIV, A(LPOS), LDAFS, & A(LPOS+1_8), LDAFS) CALL sscal(NASS-NPIV_NEW, VALPIV, A(LPOS), LDAFS) IF (NEL2.GT.0) THEN K1POS = LPOS + int(NEL2,8)*LDAFS8 NCB1 = NASS - JROW2 CALL sger(NEL2, NCB1 , ALPHA, A(APOS+1_8), 1, & A(K1POS), LDAFS, A(K1POS+1_8), LDAFS) 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) A(POSPV2) = A(POSPV1)/DETPIV A(POSPV1) = SWOP/DETPIV A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV 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 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*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 = JROW2+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A(POSPV1)*A(K1)+A(POSPV1+1_8)*A(K2)) MULT2 = - (A(POSPV1+1_8)*A(K1)+A(POSPV2)*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 ENDIF RETURN END SUBROUTINE SMUMPS_227 RECURSIVE SUBROUTINE SMUMPS_263( & 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, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 40 ), KEEP( 500 ) INTEGER(8) KEEP8(150) 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 NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER 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) ) INTEGER INTARR( max(1,KEEP(14)) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 REAL DBLARR( max(1,KEEP(13)) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER MUMPS_275 EXTERNAL MUMPS_275 INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok 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 ) LAELL = int(NPIV,8) * int(NCOLU,8) IF ( LRLU .LT. LAELL ) THEN IF ( LRLUS .LT. LAELL ) THEN IFLAG = -9 CALL MUMPS_731(LAELL - LRLUS, IERROR) GOTO 700 END IF CALL SMUMPS_94(N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP+1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' & ,LRLU,LRLUS IFLAG = -9 CALL MUMPS_731(LAELL - LRLU, IERROR) GOTO 700 END IF END IF LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLU) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_REAL, & COMM, IERR ) 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 (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_731(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) ENDIF DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), & SLAVEF ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MAITRE_DESC_BANDE, & 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDDO DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_329( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IOLDPS = PTRIST(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAVES_TOT = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAVES_TOT + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 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 FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL SMUMPS_190(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IW( IOLDPS + 6 + KEEP(IXSZ) ) = IW( IOLDPS + 6+ KEEP(IXSZ) ) + 1 IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL POSFAC = POSFAC - LAELL CALL SMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 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_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) CALL SMUMPS_62( INODE, DEST, END_NIV2_LDLT, & COMM, 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 CALL SMUMPS_759( 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, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE SMUMPS_263 SUBROUTINE SMUMPS_38( 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_38 RECURSIVE SUBROUTINE SMUMPS_80 & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, & NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & SHIFT_VAL_SON, LDA, 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE SMUMPS_OOC USE SMUMPS_COMM_BUFFER USE SMUMPS_LOAD IMPLICIT NONE INCLUDE 'smumps_root.h' INTEGER KEEP(500), ICNTL(40) INTEGER(8) KEEP8(150) 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, LDA INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL INVERT 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 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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( max(1,KEEP(14)) ) REAL DBLARR( max(1,KEEP(13)) ) 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 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 BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 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_80' CALL SMUMPS_44( MYID, SLAVEF, COMM ) 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. INVERT ) 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.INVERT).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. INVERT ) 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. INVERT ) 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. INVERT ) 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 NBPROCFILS( STEP(IROOT) ) = -1 CALL SMUMPS_284(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, IERROR ) IF (IFLAG.LT.0) THEN CALL SMUMPS_44( MYID, SLAVEF, COMM ) RETURN ENDIF ELSE NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT)) - 1 IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_681(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL SMUMPS_580(IERR) ENDIF CALL SMUMPS_507(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_500( & 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_285( 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), INVERT, & 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_285( 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), INVERT, & 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_94(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ)) COMP = COMP + 1 IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,': Error in b&scbroot: pb compress' WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL SMUMPS_648( 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, INVERT, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_329( 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, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) GOTO 500 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_80" CALL SMUMPS_44( MYID, SLAVEF, COMM ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING SMUMPS_80" IFLAG = -20 IERROR = SIZE_MSG CALL SMUMPS_44( MYID, SLAVEF, COMM ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN END SUBROUTINE SMUMPS_80 SUBROUTINE SMUMPS_285( 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, INVERT, & 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 INVERT 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. INVERT ) 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_285 SUBROUTINE SMUMPS_164 &( 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_99( 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 CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. 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_164 SUBROUTINE SMUMPS_165( 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 RETURN END SUBROUTINE SMUMPS_165 SUBROUTINE SMUMPS_99( 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_99 SUBROUTINE SMUMPS_290(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 INTEGER STATUS(MPI_STATUS_SIZE) REAL WK( MBLOCK * NBLOCK ) LOGICAL JUPDATE 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 RETURN END SUBROUTINE SMUMPS_290 SUBROUTINE SMUMPS_156(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 INTEGER STATUS(MPI_STATUS_SIZE) REAL WK( MBLOCK * NBLOCK ) LOGICAL JUPDATE 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 RETURN END SUBROUTINE SMUMPS_156 SUBROUTINE SMUMPS_284(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, IERROR ) IMPLICIT NONE INCLUDE 'smumps_root.h' INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) 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 ), PTRAIW(N), PTRARW( N ) INTEGER INTARR(max(1,KEEP(14))) REAL DBLARR(max(1,KEEP(13))) 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_760 ( 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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_284 SUBROUTINE SMUMPS_760 & ( 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_760 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 SUBROUTINE SMUMPS_XSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) CHARACTER UPLO INTEGER INCX, LDA, N REAL ALPHA REAL A( LDA, * ), X( * ) CALL ssyr( UPLO, N, ALPHA, X, INCX, A, LDA ) RETURN END SUBROUTINE SMUMPS_XSYR mumps-4.10.0.dfsg/src/cmumps_part4.F0000644000175300017530000071264711562233067017443 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C SUBROUTINE CMUMPS_246(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 & ) IMPLICIT NONE 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 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_748 EXTERNAL CMUMPS_748 INTEGER MUMPS_275, MUMPS_330 LOGICAL MUMPS_170 INTEGER MUMPS_52 EXTERNAL MUMPS_503, MUMPS_52 EXTERNAL MUMPS_275, MUMPS_330, & MUMPS_170 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)) 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 = dble(0.0E0) ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = dble(0.0E0) 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_275(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_246 ' 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_275(PROCNODE(STEP(INODE)),SLAVEF) & .EQ. MYID LEVEL = MUMPS_330(PROCNODE(STEP(INODE)),SLAVEF) INSSARBR = MUMPS_170(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_503(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_170( & 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_748( & 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_748( & 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 = NRLADU + int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU = NRLADU + int(NELIM,8)*int(NCB/NSLAVES_LOC,8) ENDIF NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) 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_246. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_275(PROCNODE(STEP(IFSON)),SLAVEF) & .EQ.MYID LEVELSON = MUMPS_330(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_246. 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_511(NFR, & NELIM, NELIM,0, & 1,OPS_NODE) ELSE CALL MUMPS_511(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_511(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 ) & ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN OPSA_LOC = OPSA_LOC + OPS_NODE / dble( SLAVEF ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(SLAVEF,8) IF (MASTER) & ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) 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_170(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_511(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_330(PROCNODE(STEP(IFATH)),SLAVEF) MASTERF= MUMPS_275(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_503( 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_246' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in CMUMPS_246 ' 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_246 RECURSIVE SUBROUTINE & CMUMPS_271( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 40 ) INTEGER(8) KEEP8(150) 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(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 PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(max(1,KEEP(14))) COMPLEX DBLARR(max(1,KEEP(13))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.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, & STATUS( MPI_STATUS_SIZE ), ISON, PDEST_MASTER_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL INVERT INCLUDE 'mumps_headers.h' INTEGER MUMPS_275, MUMPS_330 EXTERNAL MUMPS_275, MUMPS_330 FPERE = KEEP(38) TYPE_SON = MUMPS_330(PROCNODE_STEPS(STEP(INODE)),SLAVEF) IF ( MUMPS_275( 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_271 ', 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_80( 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, .FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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 INVERT = .FALSE. ELSE INVERT = .TRUE. END IF CALL CMUMPS_80( 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 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_324(A(POSELT), LDA, & NPIV, NBROW, KEEP(50)) 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_93(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_275(PROCNODE_STEPS(STEP(ISON)), SLAVEF) DO WHILE ( PTRIST(STEP(ISON)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & PDEST_MASTER_ISON, MAITRE_DESC_BANDE, & 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF ( IFLAG .LT. 0 ) RETURN ENDDO DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 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_271 ' 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 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_271", & IW(IOLDPS+XXS), "INODE=",INODE CALL MUMPS_ABORT() ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN INVERT = .FALSE. ELSE INVERT = .TRUE. END IF CALL CMUMPS_80( 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, INVERT, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL CMUMPS_314( 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, TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL CMUMPS_44( MYID, SLAVEF, COMM ) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_271 SUBROUTINE CMUMPS_221(NFRONT,NASS,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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW INTEGER(8) :: LA COMPLEX A(LA) REAL UU, SEUIL INTEGER IW(LIW) INTEGER(8) :: POSELT INTEGER IOLDPS INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INCLUDE 'mumps_headers.h' COMPLEX SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, J3, JJ INTEGER(8) :: NFRONT8 REAL AMROW REAL RMAX REAL PIVNUL COMPLEX FIXA, CSEUIL INTEGER NPIV,NASSW,IPIV INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW INTEGER CMUMPS_IXAMAX INTRINSIC max REAL, PARAMETER :: RZERO = 0.0E0 COMPLEX, PARAMETER :: ZERO = (0.0E0, 0.0E0) INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U PIVNUL = DKEEP(1) FIXA = cmplx( DKEEP(2), kind=kind(FIXA)) CSEUIL = cmplx( SEUIL, kind=kind(CSEUIL)) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NFRONT8 = int(NFRONT,8) IF (KEEP(201).EQ.1) THEN CALL CMUMPS_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL CMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_680( 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 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF (UU.GT.RZERO) GO TO 340 IF (abs(A(APOS)).EQ.RZERO) GO TO 630 GO TO 380 340 AMROW = RZERO J1 = APOS J2 = APOS + int(- NPIV + NASS - 1,8) J = NASS -NPIV JMAX = CMUMPS_IXAMAX(J,A(J1),1) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW J1 = J2 + 1_8 J2 = APOS +int(- NPIV + NFRONT - 1 - KEEP(253),8) IF (J2.LT.J1) GO TO 370 DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF ( RMAX .LE. PIVNUL ) THEN KEEP(109) = KEEP(109)+1 ISW = IOLDPS+IW(IOLDPS+1+XSIZE)+6+XSIZE+ & IW(IOLDPS+5+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)).GT. max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE. max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_762( & 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 + 5 + NPIVP1 + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + 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) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + 5 + NFRONT + NPIV + 1 +XSIZE ISWPS2 = IOLDPS + 5 + NFRONT + NPIV + JMAX +XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 WRITE(*,*) 'Detected a null pivot, INODE/NPIV=',INODE,NPIV GOTO 430 420 CONTINUE IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_680( 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_221 SUBROUTINE CMUMPS_220(NFRONT,NASS,N,INODE,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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,INOPV INTEGER(8) :: LA INTEGER KEEP(500) REAL DKEEP(30) REAL UU, SEUIL COMPLEX A(LA) INTEGER IW(LIW) REAL AMROW REAL RMAX COMPLEX SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NOFFW,NPIV,IPIV 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 CMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max REAL, PARAMETER :: RZERO = 0.0E0 NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL CMUMPS_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL CMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF DO 460 IPIV=NPIVP1,NASS APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = CMUMPS_IXAMAX(J3,A(J1),NFRONT) 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 (J3.EQ.0) GOTO 370 DO 360 J=1,J3 RMAX = max(abs(A(J1)),RMAX) J1 = J1 + NFRONT8 360 CONTINUE 370 IF (RMAX.EQ.RZERO) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)).GE.max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LT.max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_762( & 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 390 J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 390 CONTINUE 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 410 KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 410 CONTINUE 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_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_680( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE CMUMPS_220 SUBROUTINE CMUMPS_225(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_225 SUBROUTINE CMUMPS_229(NFRONT,N,INODE,IW,LIW,A,LA,IOLDPS, & POSELT,XSIZE) IMPLICIT NONE INTEGER NFRONT,N,INODE,LIW,XSIZE INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) COMPLEX ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS INTEGER(8) :: NFRONT8, LPOS, IRWPOS INTEGER IOLDPS,NPIV,NEL INTEGER JROW INCLUDE 'mumps_headers.h' COMPLEX, PARAMETER :: ONE=(1.0E0,0.0E0) NFRONT8= int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NEL = NFRONT - NPIV - 1 APOS = POSELT + int(NPIV,8) * NFRONT8 + int(NPIV,8) IF (NEL.EQ.0) GO TO 650 VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 340 JROW = 1,NEL A(LPOS) = VALPIV*A(LPOS) LPOS = LPOS + NFRONT8 340 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS+1_8 DO 440 JROW = 1,NEL IRWPOS = LPOS + 1_8 ALPHA = -A(LPOS) CALL caxpy(NEL,ALPHA,A(UUPOS),1,A(IRWPOS),1) LPOS = LPOS + NFRONT8 440 CONTINUE 650 RETURN END SUBROUTINE CMUMPS_229 SUBROUTINE CMUMPS_228(NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,N,LIW,INODE,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,KROW, XSIZE INTEGER NEL,ICOL,NEL2 INTEGER NPIVP1 COMPLEX, PARAMETER :: ONE=(1.0E0,0.0E0) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 DO 440 ICOL = 1,NEL IRWPOS = LPOS + 1_8 ALPHA = -A(LPOS) CALL caxpy(NEL2,ALPHA,A(UUPOS),1,A(IRWPOS),1) LPOS = LPOS + NFRONT8 440 CONTINUE RETURN END SUBROUTINE CMUMPS_228 SUBROUTINE CMUMPS_231(A,LA,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER(8) :: LA,POSELT COMPLEX A(LA) INTEGER NFRONT, NPIV, NASS INTEGER(8) :: LPOS, LPOS1, LPOS2 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) 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_231 SUBROUTINE CMUMPS_642(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_688 & ( 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_642 SUBROUTINE CMUMPS_232(A,LA,NFRONT,NPIV,NASS,POSELT,LKJIB) INTEGER NFRONT, NPIV, NASS, LKJIB INTEGER (8) :: POSELT, LA COMPLEX A(LA) INTEGER(8) :: POSELT_LOCAL, LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPBEG COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) POSELT_LOCAL = POSELT NEL1 = NASS - NPIV NPBEG = NPIV - LKJIB + 1 NEL11 = NFRONT - NPIV LPOS2 = POSELT_LOCAL + int(NPIV,8)*int(NFRONT,8) & + int(NPBEG - 1,8) POSELT_LOCAL = POSELT_LOCAL + int(NPBEG-1,8)*int(NFRONT,8) & + int(NPBEG-1,8) CALL ctrsm('L','L','N','N',LKJIB,NEL1,ONE,A(POSELT_LOCAL), & NFRONT,A(LPOS2),NFRONT) LPOS = LPOS2 + int(LKJIB,8) LPOS1 = POSELT_LOCAL + int(LKJIB,8) CALL cgemm('N','N',NEL11,NEL1,LKJIB,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE CMUMPS_232 SUBROUTINE CMUMPS_233(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT,XSIZE ) IMPLICIT NONE INTEGER NFRONT, NASS,N,LIW INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) INTEGER LKJIB_ORIG,LKJIB, INODE, IBEG_BLOCK INTEGER(8) :: POSELT, LPOS, LPOS1, LPOS2, POSLOCAL INTEGER(8) :: IPOS, KPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS, NPIV, JROW2, NPBEG INTEGER NONEL, LKJIW, NEL1, NEL11 INTEGER LBP, HF INTEGER LBPT,I1,K1,II,ISWOP,LBP1 INTEGER LKJIT, XSIZE INCLUDE 'mumps_headers.h' COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) JROW2 = iabs(IW(IOLDPS+3+XSIZE)) NPBEG = IBEG_BLOCK HF = 6 + IW(IOLDPS+5+XSIZE) +XSIZE NONEL = JROW2 - NPIV + 1 IF ((NASS-NPIV).GE.LKJIT) THEN LKJIB = LKJIB_ORIG + NONEL IW(IOLDPS+3+XSIZE)= min0(NPIV+LKJIB,NASS) ELSE IW(IOLDPS+3+XSIZE) = NASS ENDIF IBEG_BLOCK = NPIV + 1 NEL1 = NASS - JROW2 LKJIW = NPIV - NPBEG + 1 NEL11 = NFRONT - NPIV IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN LPOS2 = POSELT + int(JROW2,8)*NFRONT8 + & int(NPBEG - 1,8) POSLOCAL = POSELT + int(NPBEG-1,8)*NFRONT8 + int(NPBEG - 1,8) CALL ctrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSLOCAL),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSLOCAL + int(LKJIW,8) CALL cgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF RETURN END SUBROUTINE CMUMPS_233 SUBROUTINE CMUMPS_236(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_236 SUBROUTINE CMUMPS_217(N, NZ, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NZ, NSCA INTEGER IRN(NZ), ICN(NZ) INTEGER ICNTL(40), INFO(40) COMPLEX ASPK(NZ) REAL COLSCA(*), ROWSCA(*) INTEGER LWK, LWK_REAL COMPLEX WK(LWK) REAL WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER IWNOR INTEGER I, K LOGICAL PROK REAL ONE PARAMETER( ONE = 1.0E0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROK = (MPG.GT.0) IF (PROK) WRITE(MPG,101) 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROK) & WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.2) THEN IF (PROK) & WRITE (MPG,*) ' SCALING BASED ON (MC29)' 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)' ELSEIF (NSCA.EQ.5) THEN IF (PROK) & WRITE (MPG,*) ' MC29 FOLLOWED BY ROW &COL SCALING' ELSEIF (NSCA.EQ.6) THEN IF (PROK) & WRITE (MPG,*) ' MC29 FOLLOWED BY COLUMN SCALING' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF ((NSCA.EQ.5).OR. & (NSCA.EQ.6)) THEN IF (NZ.GT.LWK) GOTO 400 DO 15 K=1,NZ WK(K) = ASPK(K) 15 CONTINUE ENDIF IF (5*N.GT.LWK_REAL) GOTO 410 IWNOR = 1 IF (NSCA.EQ.1) THEN CALL CMUMPS_238(N,NZ,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.2) THEN CALL CMUMPS_239(N,NZ,ASPK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) ELSEIF (NSCA.EQ.3) THEN CALL CMUMPS_241(N,NZ,ASPK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN CALL CMUMPS_287(N,NZ,IRN,ICN,ASPK, & WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.5) THEN CALL CMUMPS_239(N,NZ,WK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) CALL CMUMPS_241(N,NZ,WK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.6) THEN CALL CMUMPS_239(N,NZ,WK,IRN,ICN, & ROWSCA,COLSCA,WK_REAL(IWNOR),MPG,MPG,NSCA) CALL CMUMPS_240(NSCA,N,NZ,IRN,ICN,WK, & WK_REAL(IWNOR+N),ROWSCA,MPG) CALL CMUMPS_241(N,NZ,WK,IRN,ICN, & WK_REAL(IWNOR), COLSCA, MPG) ENDIF GOTO 500 400 INFO(1) = -5 INFO(2) = NZ-LWK IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' 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_217 SUBROUTINE CMUMPS_287(N,NZ,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER N, NZ COMPLEX VAL(NZ) REAL RNOR(N),CNOR(N) REAL COLSCA(N),ROWSCA(N) REAL CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ), ICN(NZ) REAL VDIAG INTEGER MPRINT INTEGER I,J,K 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 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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_287 SUBROUTINE CMUMPS_239(N,NZ,VAL,ROWIND,COLIND, & RNOR,CNOR,WNOR,MPRINT,MP, & NSCA) INTEGER N, NZ COMPLEX VAL(NZ) REAL WNOR(5*N) REAL RNOR(N), CNOR(N) INTEGER COLIND(NZ),ROWIND(NZ) INTEGER J,I,K INTEGER MPRINT,MP,NSCA INTEGER IFAIL9 REAL ZERO PARAMETER( ZERO = 0.0E0) DO 15 I=1,N RNOR(I) = ZERO CNOR(I) = ZERO 15 CONTINUE CALL CMUMPS_216(N,N,NZ,VAL,ROWIND,COLIND, & RNOR,CNOR,WNOR, MP,IFAIL9) *CVD$ NODEPCHK *CVD$ VECTOR *CVD$ CONCUR DO 30 I=1,N CNOR(I) = exp(CNOR(I)) RNOR(I) = exp(RNOR(I)) 30 CONTINUE IF ((NSCA.EQ.5).OR.(NSCA.EQ.6)) THEN DO 100 K=1,NZ I = ROWIND(K) J = COLIND(K) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 100 VAL(K) = VAL(K) * CNOR(J) * RNOR(I) 100 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING USING MC29' RETURN END SUBROUTINE CMUMPS_239 SUBROUTINE CMUMPS_241(N,NZ,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER N,NZ COMPLEX VAL(NZ) REAL CNOR(N) REAL COLSCA(N) INTEGER IRN(NZ), ICN(NZ) REAL VDIAG INTEGER MPRINT INTEGER I,J,K REAL ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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_241 SUBROUTINE CMUMPS_238(N,NZ,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER N, NZ COMPLEX VAL(NZ) REAL ROWSCA(N),COLSCA(N) INTEGER IRN(NZ),ICN(NZ) REAL VDIAG INTEGER MPRINT,I,J,K INTRINSIC sqrt REAL ZERO, ONE PARAMETER(ZERO=0.0E0, ONE=1.0E0) DO 10 I=1,N ROWSCA(I) = ONE 10 CONTINUE DO 100 K=1,NZ I = IRN(K) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K) IF (I.EQ.J) THEN VDIAG = abs(VAL(K)) 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_238 SUBROUTINE CMUMPS_240(NSCA,N,NZ,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER N, NZ, NSCA INTEGER IRN(NZ), ICN(NZ) COMPLEX VAL(NZ) REAL RNOR(N) REAL ROWSCA(N) REAL VDIAG INTEGER MPRINT INTEGER I,J,K REAL ZERO,ONE PARAMETER (ZERO=0.0E0, ONE=1.0E0) DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K=1,NZ I = IRN(K) J = ICN(K) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K)) 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 K=1,NZ I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K) = VAL(K) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE CMUMPS_240 SUBROUTINE CMUMPS_216(M,N,NE,A,IRN,ICN,R,C,W,LP,IFAIL) INTEGER M,N,NE COMPLEX A(NE) INTEGER IRN(NE),ICN(NE) REAL R(M),C(N) REAL W(M*2+N*3) INTEGER LP,IFAIL INTRINSIC log,abs,min INTEGER MAXIT PARAMETER (MAXIT=100) REAL ONE REAL SMIN,ZERO PARAMETER (ONE=1.0E0,SMIN=0.1E0,ZERO=0.0E0) INTEGER I,I1,I2,I3,I4,I5,ITER,J,K REAL E,E1,EM,Q,Q1,QM,S,S1,SM,U,V IFAIL = 0 IF (M.LT.1 .OR. N.LT.1) THEN IFAIL = -1 GO TO 220 ELSE IF (NE.LE.0) THEN IFAIL = -2 GO TO 220 END IF I1 = 0 I2 = M I3 = M + N I4 = M + N*2 I5 = M + N*3 DO 10 I = 1,M R(I) = ZERO W(I1+I) = ZERO 10 CONTINUE DO 20 J = 1,N C(J) = ZERO W(I2+J) = ZERO W(I3+J) = ZERO W(I4+J) = ZERO 20 CONTINUE DO 30 K = 1,NE U = abs(A(K)) IF (U.EQ.ZERO) GO TO 30 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 30 U = log(U) W(I1+I) = W(I1+I) + ONE W(I2+J) = W(I2+J) + ONE R(I) = R(I) + U W(I3+J) = W(I3+J) + U 30 CONTINUE DO 40 I = 1,M IF (W(I1+I).EQ.ZERO) W(I1+I) = ONE R(I) = R(I)/W(I1+I) W(I5+I) = R(I) 40 CONTINUE DO 50 J = 1,N IF (W(I2+J).EQ.ZERO) W(I2+J) = ONE W(I3+J) = W(I3+J)/W(I2+J) 50 CONTINUE SM = SMIN*real(NE) DO 60 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 60 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 60 R(I) = R(I) - W(I3+J)/W(I1+I) 60 CONTINUE E = ZERO Q = ONE S = ZERO DO 70 I = 1,M S = S + W(I1+I)*R(I)**2 70 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 160 DO 150 ITER = 1,MAXIT DO 80 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 80 J = ICN(K) I = IRN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 80 C(J) = C(J) + R(I) 80 CONTINUE S1 = S S = ZERO DO 90 J = 1,N V = -C(J)/Q C(J) = V/W(I2+J) S = S + V*C(J) 90 CONTINUE E1 = E E = Q*S/S1 Q = ONE - E IF (abs(S).LE.abs(SM)) E = ZERO DO 100 I = 1,M R(I) = R(I)*E*W(I1+I) 100 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 180 EM = E*E1 DO 110 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 110 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 110 R(I) = R(I) + C(J) 110 CONTINUE S1 = S S = ZERO DO 120 I = 1,M V = -R(I)/Q R(I) = V/W(I1+I) S = S + V*R(I) 120 CONTINUE E1 = E E = Q*S/S1 Q1 = Q Q = ONE - E IF (abs(S).LE.abs(SM)) Q = ONE QM = Q*Q1 DO 130 J = 1,N W(I4+J) = (EM*W(I4+J)+C(J))/QM W(I3+J) = W(I3+J) + W(I4+J) 130 CONTINUE IF (abs(S).LE.abs(SM)) GO TO 160 DO 140 J = 1,N C(J) = C(J)*E*W(I2+J) 140 CONTINUE 150 CONTINUE 160 DO 170 I = 1,M R(I) = R(I)*W(I1+I) 170 CONTINUE 180 DO 190 K = 1,NE IF (abs(A(K)).EQ.ZERO) GO TO 190 I = IRN(K) J = ICN(K) IF (min(I,J).LT.1 .OR. I.GT.M .OR. J.GT.N) GO TO 190 R(I) = R(I) + W(I3+J) 190 CONTINUE DO 200 I = 1,M R(I) = R(I)/W(I1+I) - W(I5+I) 200 CONTINUE DO 210 J = 1,N C(J) = -W(I3+J) 210 CONTINUE RETURN 220 IF (LP.GT.0) WRITE (LP,'(/A/A,I3)') & ' **** Error return from CMUMPS_216 ****',' IFAIL =',IFAIL END SUBROUTINE CMUMPS_216 SUBROUTINE CMUMPS_27( 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_207(id%A(1), & id%NZ, id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL CMUMPS_289(id%A(1), & id%NZ, 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_119(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL CMUMPS_135(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, 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%NZ_loc .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL CMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1) ) ELSE CALL CMUMPS_289(id%A_loc(1), & id%NZ_loc, 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_27 SUBROUTINE CMUMPS_693(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, M, 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 RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) REAL ROWSCA(M) REAL COLSCA(N) INTEGER ISZWRKRC REAL WRKRC(ISZWRKRC) REAL ONENORMERR,INFNORMERR INTEGER SYM, NB1, NB2, NB3 REAL EPS EXTERNAL CMUMPS_694,CMUMPS_687, & CMUMPS_670 INTEGER I IF(SYM.EQ.0) THEN CALL CMUMPS_694(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_687(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_693 SUBROUTINE CMUMPS_694(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, M, 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 RPARTVEC(M), RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N), CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) REAL ROWSCA(M) REAL COLSCA(N) INTEGER ISZWRKRC REAL WRKRC(ISZWRKRC) REAL ONENORMERR,INFNORMERR INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC 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 INTEGER NB1, NB2, NB3 REAL EPS INTEGER ITER, NZIND, IR, IC REAL ELM 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) EXTERNAL CMUMPS_654, & CMUMPS_672, & CMUMPS_674, & CMUMPS_662, & CMUMPS_743, & CMUMPS_745, & CMUMPS_660, & CMUMPS_670, & CMUMPS_671, & CMUMPS_657, & CMUMPS_656 INTEGER CMUMPS_743 INTEGER CMUMPS_745 REAL CMUMPS_737 REAL CMUMPS_738 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) 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 IF(OP == 1) THEN IF(NUMPROCS > 1) THEN CALL CMUMPS_654(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ) CALL CMUMPS_654(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ) CALL CMUMPS_672(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_672(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_662(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 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0 ENDIF RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL RESZ = RESZR + RESZC 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 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 CALL CMUMPS_660(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 IRNGHBPRCS = IMYCPTR+ INUMMYC IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1 OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM OCSNDRCVJA = OCSNDRCVIA + NUMPROCS + 1 REQUESTS = OCSNDRCVJA + OCSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL CMUMPS_674(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_674(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_670(ROWSCA, M, RZERO) CALL CMUMPS_670(COLSCA, N, RZERO) CALL CMUMPS_671(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE) CALL CMUMPS_671(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE) ELSE CALL CMUMPS_670(ROWSCA, M, RONE) CALL CMUMPS_670(COLSCA, N, RONE) ENDIF ITDRPTR = 1 ITDCPTR = ITDRPTR + M ISRRPTR = ITDCPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL ISRCPTR = OSRRPTR + ORSNDRCVVOL OSRCPTR = ISRCPTR + ICSNDRCVVOL IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1 ISRCPTR = ISRCPTR - 1 OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) IF(NUMPROCS > 1) THEN CALL CMUMPS_650(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) CALL CMUMPS_650(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) ELSE CALL CMUMPS_670(WRKRC(ITDRPTR),M, RZERO) CALL CMUMPS_670(WRKRC(ITDCPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1,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_657(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) CALL CMUMPS_657(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_737(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) INFERRCOL = CMUMPS_737(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL CMUMPS_665(COLSCA, WRKRC(ITDCPTR), & N, & IWRK(IMYCPTR),INUMMYC) CALL CMUMPS_665(ROWSCA, WRKRC(ITDRPTR), & M, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = CMUMPS_738(ROWSCA, & WRKRC(ITDRPTR), M) INFERRCOL = CMUMPS_738(COLSCA, & WRKRC(ITDCPTR), N) INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL CMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL CMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE IF((ITER .EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1,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_656(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) CALL CMUMPS_656(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_737(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) ONEERRCOL = CMUMPS_737(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_665(COLSCA, WRKRC(ITDCPTR), & N, & IWRK(IMYCPTR),INUMMYC) CALL CMUMPS_665(ROWSCA, WRKRC(ITDRPTR), & M, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = CMUMPS_738(ROWSCA, & WRKRC(ITDRPTR), M) ONEERRCOL = CMUMPS_738(COLSCA, & WRKRC(ITDCPTR), N) ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL CMUMPS_666(ROWSCA, WRKRC(ITDRPTR), M) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL CMUMPS_665(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) CALL CMUMPS_665(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) ELSE CALL CMUMPS_666(COLSCA, WRKRC(ITDCPTR), N) CALL CMUMPS_666(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 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_694 SUBROUTINE CMUMPS_687(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) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER NZ_loc, 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) INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ISRRPTR, OSRRPTR REAL ONENORMERR,INFNORMERR INTEGER NB1, NB2, NB3 REAL EPS INTEGER ITER, NZIND, IR, IC REAL ELM INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) EXTERNAL CMUMPS_655, & CMUMPS_673, & CMUMPS_692, & CMUMPS_663, & CMUMPS_742, & CMUMPS_745, & CMUMPS_661, & CMUMPS_657, & CMUMPS_656, & CMUMPS_670, & CMUMPS_671 INTEGER CMUMPS_742 INTEGER CMUMPS_745 REAL CMUMPS_737 REAL CMUMPS_738 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) 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 CALL CMUMPS_655(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ) CALL CMUMPS_673(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc,JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL CMUMPS_663(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWRKSZ) INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZ = INTSZR + N + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0 ENDIF RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) INUMMYR = REGISTRE(9) IF(NUMPROCS > 1) THEN CALL CMUMPS_661(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-INUMMYR) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 REQUESTS = ORSNDRCVJA + ORSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL CMUMPS_692(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_670(SCA, N, RZERO) CALL CMUMPS_671(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE) ELSE CALL CMUMPS_670(SCA, N, RONE) ENDIF ITDRPTR = 1 ISRRPTR = ITDRPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) IF(NUMPROCS > 1) THEN CALL CMUMPS_650(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL CMUMPS_670(WRKRC(ITDRPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1,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_657(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_737(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_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = CMUMPS_738(SCA, & WRKRC(ITDRPTR), N) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL CMUMPS_666(SCA, WRKRC(ITDRPTR), N) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1,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,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_656(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_737(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = CMUMPS_738(SCA, & WRKRC(ITDRPTR), N) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_666(SCA, WRKRC(ITDRPTR), N) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL CMUMPS_665(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL CMUMPS_666(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_687 SUBROUTINE CMUMPS_654(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL CMUMPS_703 INTEGER MYID, NUMPROCS, COMM INTEGER NZ_loc, ISZ, IWSZ, OSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWSZ) INCLUDE 'mpif.h' INTEGER I INTEGER OP, IERROR INTEGER IR, IC IF(NUMPROCS.NE.1) THEN CALL MPI_OP_CREATE(CMUMPS_703, .TRUE., OP, IERROR) CALL CMUMPS_668(IWRK, 4*ISZ, ISZ) DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_654 SUBROUTINE CMUMPS_662(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, M, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER INUMMYR, INUMMYC INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC INUMMYR = 0 INUMMYC = 0 DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRK(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I=1,NZ_loc IC = JCN_loc(I) IR = IRN_loc(I) 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 RETURN END SUBROUTINE CMUMPS_662 SUBROUTINE CMUMPS_660(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, 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 INTEGER I, IR, IC, ITMP, MAXMN MAXMN = M IF(N > MAXMN) MAXMN = N DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_660 INTEGER FUNCTION CMUMPS_744(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL EPS INTEGER I, IID REAL RONE PARAMETER(RONE=1.0E0) CMUMPS_744 = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN CMUMPS_744 = 0 ENDIF ENDDO RETURN END FUNCTION CMUMPS_744 INTEGER FUNCTION CMUMPS_745(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL EPS INTEGER I REAL RONE PARAMETER(RONE=1.0E0) CMUMPS_745 = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN CMUMPS_745 = 0 ENDIF ENDDO RETURN END FUNCTION CMUMPS_745 INTEGER FUNCTION CMUMPS_743(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_744 INTEGER CMUMPS_744 INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = CMUMPS_744(DR, M, INDXR, INDXRSZ, EPS) MYRESC = CMUMPS_744(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) CMUMPS_743 = GLORES RETURN END FUNCTION CMUMPS_743 REAL FUNCTION CMUMPS_737(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) 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_737 = ERRMAX RETURN END FUNCTION CMUMPS_737 REAL FUNCTION CMUMPS_738(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL TMPD(DSZ) 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_738 = ERRMAX1 RETURN END FUNCTION CMUMPS_738 SUBROUTINE CMUMPS_665(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt 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_665 SUBROUTINE CMUMPS_666(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL TMPD(DSZ) INTRINSIC sqrt 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_666 SUBROUTINE CMUMPS_671(D, DSZ, INDX, INDXSZ, VAL) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL VAL INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO RETURN END SUBROUTINE CMUMPS_671 SUBROUTINE CMUMPS_702(D, DSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = 1.0E0/D(IIND) ENDDO RETURN END SUBROUTINE CMUMPS_702 SUBROUTINE CMUMPS_670(D, DSZ, VAL) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL VAL INTEGER I DO I=1,DSZ D(I) = VAL ENDDO RETURN END SUBROUTINE CMUMPS_670 SUBROUTINE CMUMPS_650(TMPD, TMPSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER TMPSZ,INDXSZ REAL TMPD(TMPSZ) INTEGER INDX(INDXSZ) INTEGER I REAL DZERO PARAMETER(DZERO=0.0E0) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO RETURN END SUBROUTINE CMUMPS_650 SUBROUTINE CMUMPS_703(INV, INOUTV, LEN, DTYPE) IMPLICIT NONE INTEGER LEN INTEGER INV(2*LEN) INTEGER INOUTV(2*LEN) INTEGER DTYPE INTEGER I INTEGER DIN, DINOUT, PIN, PINOUT DO I=1,2*LEN-1,2 DIN = INV(I) PIN = INV(I+1) DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_703 SUBROUTINE CMUMPS_668(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER IWSZ INTEGER IW(IWSZ) INTEGER IVAL INTEGER I DO I=1,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE CMUMPS_668 SUBROUTINE CMUMPS_704(MYID, NUMPROCS, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRKROW, IWRKCOL, IWSZR, IWSZC, COMM ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, M, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(M) INTEGER MYCOLINDICES(N) INTEGER INUMMYR, INUMMYC INTEGER IWSZR, IWSZC INTEGER IWRKROW(IWSZR) INTEGER IWRKCOL(IWSZC) INTEGER COMM INTEGER I, IR, IC, ITMP INUMMYR = 0 INUMMYC = 0 DO I=1,M IWRKROW(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRKROW(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRKROW(IR) .EQ. 0) THEN IWRKROW(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO ITMP = 1 DO I=1,M IF(IWRKROW(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO DO I=1,N IWRKCOL(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRKCOL(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRKCOL(IC) .EQ. 0) THEN IWRKCOL(IC)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDIF ENDDO ITMP = 1 DO I=1,N IF(IWRKCOL(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_704 SUBROUTINE CMUMPS_672(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ, OSZ INTEGER ISNDRCVNUM, ISNDRCVVOL INTEGER OSNDRCVNUM, OSNDRCVVOL INTEGER COMM INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWRKSZ) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INCLUDE 'mpif.h' INTEGER I INTEGER IIND, IIND2, PIND INTEGER IERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO DO I=1,NZ_loc IIND = INDX(I) IIND2 = OINDX(I) 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 IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 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_672 SUBROUTINE CMUMPS_674(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 MYID, NUMPROCS, NZ_loc, ISZ, ISNDVOL, OSNDVOL, OSZ INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) 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 INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR DO I=1,ISZ IWRK(I) = 0 ENDDO 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 DO I=1,NZ_loc IIND=INDX(I) IIND2 = OINDX(I) 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 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_674 SUBROUTINE CMUMPS_657(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 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 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 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_657 SUBROUTINE CMUMPS_656(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 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 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 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_656 SUBROUTINE CMUMPS_655(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL CMUMPS_703 INTEGER MYID, NUMPROCS, COMM INTEGER NZ_loc, ISZ, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWSZ) INCLUDE 'mpif.h' INTEGER I INTEGER OP, IERROR INTEGER IR, IC IF(NUMPROCS.NE.1) THEN CALL MPI_OP_CREATE(CMUMPS_703, .TRUE., OP, IERROR) CALL CMUMPS_668(IWRK, 4*ISZ, ISZ) DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_655 SUBROUTINE CMUMPS_673(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, ISZ, IWRKSZ INTEGER ISNDRCVNUM, ISNDRCVVOL INTEGER OSNDRCVNUM, OSNDRCVVOL INTEGER COMM INTEGER INDX(NZ_loc), OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) INTEGER IWRK(IWRKSZ) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INCLUDE 'mpif.h' INTEGER I INTEGER IIND, IIND2, PIND INTEGER IERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO DO I=1,NZ_loc IIND = INDX(I) IIND2 = OINDX(I) 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 IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I) 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 CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) 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_673 SUBROUTINE CMUMPS_663(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, N INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER INUMMYR INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC INUMMYR = 0 DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 RETURN END SUBROUTINE CMUMPS_663 INTEGER FUNCTION CMUMPS_742(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_744 INTEGER CMUMPS_744 INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = CMUMPS_744(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) CMUMPS_742 = GLORES RETURN END FUNCTION CMUMPS_742 SUBROUTINE CMUMPS_661(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, NZ_loc, N INTEGER INUMMYR, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM INTEGER I, IR, IC, ITMP, MAXMN MAXMN = N DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I=1,NZ_loc IR = IRN_loc(I) IC = JCN_loc(I) 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 ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_661 SUBROUTINE CMUMPS_692(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, NZ_loc, ISZ, ISNDVOL, OSNDVOL INTEGER INDX(NZ_loc), OINDX(NZ_loc) INTEGER IPARTVEC(ISZ) 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 INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR DO I=1,ISZ IWRK(I) = 0 ENDDO 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 DO I=1,NZ_loc IIND=INDX(I) IIND2 = OINDX(I) 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(I) 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 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_692 SUBROUTINE CMUMPS_628(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_628 SUBROUTINE CMUMPS_629 &(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_729( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE CMUMPS_629 SUBROUTINE CMUMPS_630(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_630 SUBROUTINE CMUMPS_631(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_631 SUBROUTINE CMUMPS_94(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE) 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) 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 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) RETURN 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_629(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_729(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_630(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_631(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_94" ENDIF IF (RBEGCONTIG > 0_8) GOTO 25 CALL CMUMPS_629 & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL CMUMPS_628(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL CMUMPS_627(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_627(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_729(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL CMUMPS_631(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_724(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_729( 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_94" 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 RETURN END SUBROUTINE CMUMPS_94 SUBROUTINE CMUMPS_632(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_729(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_632 SUBROUTINE CMUMPS_627(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_627" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in CMUMPS_627" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in CMUMPS_627",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_627 SUBROUTINE CMUMPS_700(BUFR,LBUFR, & LBUFR_BYTES, & root, N, IW, LIW, A, LA, & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP,KEEP8, 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) 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_S(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 ), PTRAIW(N), PTRARW( N ) INTEGER INTARR(max(1,KEEP(14))) COMPLEX DBLARR(max(1,KEEP(13))) INCLUDE 'mpif.h' INTEGER IERR 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_S( 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 ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_681(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL CMUMPS_580(IERR) ENDIF CALL CMUMPS_507( 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_500( & 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 ENDIF IF (KEEP(60) == 0) THEN CALL CMUMPS_284( 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, 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_S(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST_S(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_700' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_38( 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 CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) 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_700' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL CMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_38( 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_38( 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 CALL CMUMPS_471(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLU) ENDIF RETURN END SUBROUTINE CMUMPS_700 SUBROUTINE CMUMPS_762(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_762 SUBROUTINE CMUMPS_761(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_761 SUBROUTINE CMUMPS_763(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_762(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_763 SUBROUTINE CMUMPS_764( & 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_771 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_771, & .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_764 SUBROUTINE CMUMPS_771(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE INTEGER, INTENT(IN) :: NEL, DATATYPE 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_762(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_771 SUBROUTINE CMUMPS_765(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP COMPLEX, intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE CMUMPS_765 SUBROUTINE CMUMPS_766(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER DETER=1.0E0/DETER NEXP=-NEXP RETURN END SUBROUTINE CMUMPS_766 SUBROUTINE CMUMPS_767(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_767 SUBROUTINE CMUMPS_224(NFRONT,NASS,IBEGKJI, LPIV, TIPIV, & 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) USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER IBEGKJI, LPIV INTEGER TIPIV(LPIV) INTEGER(8) :: LA COMPLEX A(LA) INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV,NOFFW REAL UU, SEUIL 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(30) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U COMPLEX SWOP INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3_8 INTEGER(8) :: NFRONT8 INTEGER ILOC COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) REAL RZERO, RMAX, AMROW, ONE REAL PIVNUL COMPLEX FIXA, CSEUIL INTEGER NPIV,NASSW,IPIV INTEGER NPIVP1,JMAX,J3,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF INCLUDE 'mumps_headers.h' INTEGER CMUMPS_IXAMAX INTRINSIC max DATA RZERO /0.0E0/ DATA ONE /1.0E0/ INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER XSIZE PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) NFRONT8=int(NFRONT,8) 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_667(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL CMUMPS_667(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ILOC = NPIVP1 - IBEGKJI + 1 TIPIV(ILOC) = ILOC NASSW = iabs(IW(IOLDPS+3+XSIZE)) 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_762(A(APOS), DKEEP(6), KEEP(259)) ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_680( 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 DO 460 IPIV=NPIVP1,NASSW APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF (UU.GT.RZERO) GO TO 340 IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 340 AMROW = RZERO J1 = APOS J2 = APOS +int(- NPIV + NASS - 1,8) J3 = NASS -NPIV JMAX = CMUMPS_IXAMAX(J3,A(J1),1) JJ = int(JMAX,8) + J1 - 1_8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = J2 + 1_8 J2 = APOS +int(- NPIV + NFRONT - KEEP(253)- 1,8) IF (J2.LT.J1) GO TO 370 DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE 370 IDIAG = APOS + int(IPIV - NPIVP1,8) IF (RMAX.LE.PIVNUL) THEN KEEP(109) = KEEP(109)+1 ISW = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6+KEEP(IXSZ)+ & IW(IOLDPS+5+KEEP(IXSZ))+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 - KEEP(253) - 1,8) DO JJ=J1,J2 A(JJ)= ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF IF (abs(A(IDIAG)).GT.max(UU*RMAX,SEUIL)) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF (AMROW.LE.max(UU*RMAX,SEUIL)) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (KEEP(258).NE.0) THEN CALL CMUMPS_762( 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_8 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3_8) A(J3_8) = SWOP J3_8 = J3_8 + 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) TIPIV(ILOC) = ILOC + JMAX - 1 J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,NASS 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 (NASSW.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 WRITE(*,*) 'NIV2:Detected 0 pivot, INODE,NPIV=',INODE,NPIV GOTO 430 420 CONTINUE IF (KEEP(201).EQ.1) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_680( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_680( 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_224 SUBROUTINE CMUMPS_294( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & IW, LIW, & IOLDPS, POSELT, A, LA, LDA_FS, & IBEGKJI, 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE CMUMPS_COMM_BUFFER USE CMUMPS_LOAD IMPLICIT NONE INCLUDE 'cmumps_root.h' INCLUDE 'mpif.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEGKJI, 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) 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), & PTRARW(LPTRAR), PTRAIW(LPTRAR), & ND( KEEP(28) ), FRERE( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(max(1,KEEP(14))) 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(max(1,KEEP(13))) EXTERNAL CMUMPS_329 INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES 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_294 ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEGKJI + 1 NCOL = LDA_FS - IBEGKJI + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEGKJI-1,8) + & int(IBEGKJI - 1,8) IF (IBEGKJI > 0) THEN CALL MUMPS_511( LDA_FS, IBEGKJI-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_511( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL CMUMPS_190(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTBL)) ) THEN PDEST = IOLDPS + 6 + KEEP(IXSZ) IERR = -1 IF ( NPIV .NE. 0 ) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF DO WHILE (IERR .EQ.-1) CALL CMUMPS_65( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTBL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP(50), NB_BLOC_FAC, & COMM, IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_329( 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, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) IF (MESSAGE_RECEIVED) POSELT = PTRAST(STEP(INODE)) 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 CALL MUMPS_731( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL CMUMPS_44( MYID, SLAVEF, COMM ) 500 RETURN END SUBROUTINE CMUMPS_294 SUBROUTINE CMUMPS_273( 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, & 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) 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_330 EXTERNAL MUMPS_330 IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_330(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_22(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,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_273', & ' 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_507(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_500( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE CMUMPS_273 SUBROUTINE CMUMPS_363(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_275 INTEGER MUMPS_275 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_170,MUMPS_167 LOGICAL MUMPS_170,MUMPS_167 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_363",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_363' 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_363' 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_363' 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_363' 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_363' 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_363' 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_462(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_363' 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_170(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_170(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_170(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_170(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_462(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_462(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_462(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(*,*)'Probleme dans reorder!!!!' 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_462(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_511(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_167(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_170( & 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_511(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_170( & PROCNODE(STEP(INODE)),SLAVEF)))THEN CALL CMUMPS_462(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_363 SUBROUTINE CMUMPS_364(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_283,MUMPS_275 LOGICAL MUMPS_283 INTEGER MUMPS_275 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 INDICE(SLAVEF),ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_170,MUMPS_167 LOGICAL MUMPS_170,MUMPS_167 DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK 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 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_363",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)) RETURN 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_363' 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_363' 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_363' 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_363' 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_462(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_363' 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_167(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_283(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_167(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_511(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_167(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_283(PROCNODE(STEP(INODE)),SLAVEF))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_275(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_275(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_167(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_275(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_170(PROCNODE(STEP(INODE)), & SLAVEF))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_283(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) 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_364 RECURSIVE SUBROUTINE CMUMPS_462(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_462(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL CMUMPS_462(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_462 mumps-4.10.0.dfsg/src/mumps_headers.h0000644000175300017530000000651711562233011017700 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C INTEGER XXI, XXR, XXS, XXN, XXP PARAMETER(XXI=0,XXR=1,XXS=3,XXN=4,XXP=5) INTEGER XXNDIAG2W PARAMETER(XXNDIAG2W=6) INTEGER XSIZE_IC, XSIZE_OOC_SYM, XSIZE_OOC_UNSYM INTEGER XSIZE_OOC_NOPANEL PARAMETER (XSIZE_IC=6,XSIZE_OOC_SYM=7,XSIZE_OOC_UNSYM=7, * XSIZE_OOC_NOPANEL=6) INTEGER IXSZ PARAMETER(IXSZ= 222) 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=3, XTRA_SLAVES_UNSYM=1) INTEGER S_ROOT2SON_CALLED, S_REC_CONTSTATIC, & S_ROOTBAND_INIT PARAMETER(S_ROOT2SON_CALLED=-341,S_REC_CONTSTATIC=1, & S_ROOTBAND_INIT=0) mumps-4.10.0.dfsg/src/zmumps_struc_def.F0000644000175300017530000000430311562233070020367 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE ZMUMPS_STRUC_DEF INCLUDE 'zmumps_struc.h' END MODULE ZMUMPS_STRUC_DEF mumps-4.10.0.dfsg/src/smumps_comm_buffer.F0000644000175300017530000031005611562233065020677 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE SMUMPS_COMM_BUFFER PRIVATE PUBLIC :: SMUMPS_61, SMUMPS_528, & SMUMPS_53 , SMUMPS_57 , & SMUMPS_55, SMUMPS_59, & SMUMPS_54,SMUMPS_58, & SMUMPS_66, SMUMPS_78, & SMUMPS_62, SMUMPS_68, & SMUMPS_71, SMUMPS_70, & SMUMPS_67, & SMUMPS_65, SMUMPS_64, & SMUMPS_72, & SMUMPS_648, SMUMPS_76, & SMUMPS_73, SMUMPS_74, & SMUMPS_63,SMUMPS_77, & SMUMPS_60, & SMUMPS_524, SMUMPS_469, & SMUMPS_460, SMUMPS_502, & SMUMPS_519 ,SMUMPS_620 & ,SMUMPS_617 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 BUF_LMAX_ARRAY REAL, DIMENSION(:), ALLOCATABLE :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY CONTAINS SUBROUTINE SMUMPS_528( MYID ) IMPLICIT NONE INTEGER MYID BUF_MYID = MYID RETURN END SUBROUTINE SMUMPS_528 SUBROUTINE SMUMPS_61( 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_61 SUBROUTINE SMUMPS_53( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL SMUMPS_2( BUF_CB, SIZE, IERR ) RETURN END SUBROUTINE SMUMPS_53 SUBROUTINE SMUMPS_55( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL SMUMPS_2( BUF_SMALL, SIZE, IERR ) RETURN END SUBROUTINE SMUMPS_55 SUBROUTINE SMUMPS_54( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL SMUMPS_2( BUF_LOAD, SIZE, IERR ) RETURN END SUBROUTINE SMUMPS_54 SUBROUTINE SMUMPS_58( IERR ) IMPLICIT NONE INTEGER IERR CALL SMUMPS_3( BUF_LOAD, IERR ) RETURN END SUBROUTINE SMUMPS_58 SUBROUTINE SMUMPS_620() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE SMUMPS_620 SUBROUTINE SMUMPS_617(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_617 SUBROUTINE SMUMPS_57( IERR ) IMPLICIT NONE INTEGER IERR CALL SMUMPS_3( BUF_CB, IERR ) RETURN END SUBROUTINE SMUMPS_57 SUBROUTINE SMUMPS_59( IERR ) IMPLICIT NONE INTEGER IERR CALL SMUMPS_3( BUF_SMALL, IERR ) RETURN END SUBROUTINE SMUMPS_59 SUBROUTINE SMUMPS_2( 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 SMUMPS_2 SUBROUTINE SMUMPS_3( 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 on SGI' 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 SMUMPS_3 SUBROUTINE SMUMPS_66( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, COMPRESSCB, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT 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_79( 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 NBROWS_PACKET = SIZE_AV_REALS / LCONT 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 SMUMPS_4( 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 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 SMUMPS_1( 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_66 SUBROUTINE SMUMPS_72( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, CB, SOL, & DEST, COMM, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR REAL CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) REAL SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) 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( 4, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_REAL, COMM, & SIZE2, IERR ) SIZE = SIZE1 + SIZE2 CALL SMUMPS_4( 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 ) 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 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 SMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_72 SUBROUTINE SMUMPS_78( NRHS, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS, NODE1, NODE2, NCB, LONG INTEGER IW( max( 1, LONG ) ) REAL W( max( 1, LDW * NRHS ) ) 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( 2+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS*LONG, MPI_REAL, & COMM, SIZE2, IERR ) END IF SIZE = SIZE1 + SIZE2 CALL SMUMPS_4( 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 ) END IF 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 ) DO K=1, NRHS CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) END DO END IF CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), IERR ) IF ( SIZE .NE. POSITION ) CALL SMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_78 SUBROUTINE SMUMPS_62( I, DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER I INTEGER DEST, TAG, COMM, IERR 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 SMUMPS_4( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN write(6,*) ' Internal error in SMUMPS_62', & ' 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 ) CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR ) RETURN END SUBROUTINE SMUMPS_62 SUBROUTINE SMUMPS_469(FLAG) LOGICAL FLAG LOGICAL FLAG1, FLAG2, FLAG3 CALL SMUMPS_468( BUF_SMALL, FLAG1 ) CALL SMUMPS_468( BUF_CB, FLAG2 ) CALL SMUMPS_468( BUF_LOAD, FLAG3 ) FLAG = FLAG1 .AND. FLAG2 .AND. FLAG3 RETURN END SUBROUTINE SMUMPS_469 SUBROUTINE SMUMPS_468( B, FLAG ) TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B LOGICAL :: FLAG INTEGER SIZE_AVAIL CALL SMUMPS_79(B, SIZE_AVAIL) FLAG = ( B%HEAD == B%TAIL ) RETURN END SUBROUTINE SMUMPS_468 SUBROUTINE SMUMPS_79( 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_79 SUBROUTINE SMUMPS_4( B, IPOS, IREQ, MSG_SIZE, IERR, & NDEST , PDEST & ) IMPLICIT NONE TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER, INTENT(IN) :: MSG_SIZE INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR 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 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 SMUMPS_4 SUBROUTINE SMUMPS_1( 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 SMUMPS_1 SUBROUTINE SMUMPS_68( & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, & NASS, NSLAVES, LIST_SLAVES, & DEST, NFRONT, COMM, IERR ) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER INODE INTEGER NLIG, NCOL, NASS, NSLAVES INTEGER NBPROCFILS, DEST INTEGER ILIG( NLIG ) INTEGER ICOL( NCOL ) INTEGER LIST_SLAVES( NSLAVES ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER SIZE, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE = ( 6 + NLIG + NCOL + NSLAVES + 1 ) * SIZEofINT IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -2 RETURN END IF CALL SMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS 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 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 ) THEN WRITE(*,*) 'Error in SMUMPS_68 :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, MPI_PACKED, & DEST, MAITRE_DESC_BANDE, COMM, & BUF_CB%CONTENT( IREQ ), IERR ) RETURN END SUBROUTINE SMUMPS_68 SUBROUTINE SMUMPS_70( 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 ( ( KEEP(48).NE. 0 ).AND.(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_79( 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 SMUMPS_4( 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 ( ( KEEP(48).NE. 0 ).AND.(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 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 SMUMPS_1( 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_70 SUBROUTINE SMUMPS_67(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_617(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_729( 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_79( 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*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 ! defined(DBG_SMB3) 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 #endif CALL SMUMPS_4( 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 IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 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( 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_47( & 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_47( & 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_67" 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_618( & 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 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 SMUMPS_1( 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_67 SUBROUTINE SMUMPS_71( & 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF CALL SMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST & ) IF (IERR .LT. 0 ) THEN RETURN ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN 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 ) = NCBSON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF (( NSLAVES.GT.0 ) .AND. (KEEP(48).NE.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_71 :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) ENDIF CALL SMUMPS_79( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE ) THEN IERR = -1 RETURN END IF DO IDEST= 1, NDEST CALL MUMPS_49( & 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF ( MYID .NE. DEST( IDEST ) ) THEN CALL SMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST(IDEST) & ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Problem in SMUMPS_4: IERR<0' CALL MUMPS_ABORT() END IF IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 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 ) = TROW_SIZE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF (( NSLAVES.GT.0 ) .AND. (KEEP(48).NE.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 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_71 SUBROUTINE SMUMPS_65( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL, & PDEST, NDEST, KEEP50, NB_BLOC_FAC, COMM, IERR ) IMPLICIT NONE INTEGER INODE, NCOL, NPIV, FPERE, NFRONT, NDEST INTEGER IPIV( NPIV ) REAL VAL( NFRONT, * ) INTEGER PDEST( NDEST ) INTEGER KEEP50, NB_BLOC_FAC, COMM, IERR LOGICAL LASTBL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE, & IDEST, IPOSMSG, I INTEGER NPIVSENT INTEGER SSS, SS2 IERR = 0 IF ( LASTBL ) THEN IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF ELSE IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF END IF SIZE2 = 0 IF (NPIV.GT.0) & CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_REAL, & COMM, SIZE2, IERR ) SIZE = SIZE1 + SIZE2 CALL SMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & NDEST , PDEST & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES) THEN SSS = 0 IF ( LASTBL ) THEN IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) END IF ELSE IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) END IF END IF IF (NPIV.GT.0) & CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_REAL, & COMM, SS2, IERR ) SSS = SSS + SS2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF 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 ), SIZE, & POSITION, COMM, IERR ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) IF ( LASTBL .or. KEEP50.ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END IF IF ( LASTBL .AND. KEEP50 .NE. 0 ) THEN CALL MPI_PACK( NDEST, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) IF ( NPIV.GT.0) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NCOL, & MPI_REAL, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END DO ENDIF DO IDEST = 1, NDEST IF ( KEEP50.eq.0) THEN CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR ) ELSE CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR ) END IF END DO SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL SMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_65 SUBROUTINE SMUMPS_64( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU, & NDEST, PDEST, COMM, IERR ) IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE REAL UIP21K( NPIV, NCOLU ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE, & IDEST, IPOSMSG, SSS, SS2 IERR = 0 CALL MPI_PACK_SIZE( 6 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_REAL, & COMM, SIZE2, IERR ) SIZE = SIZE1 + SIZE2 IF (SIZE.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR ) CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_REAL, & COMM, SS2, IERR ) SSS = SSS+SS2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF CALL SMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, 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 ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( UIP21K, abs(NPIV) * NCOLU, & MPI_REAL, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) DO IDEST = 1, NDEST 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 SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL SMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_64 SUBROUTINE SMUMPS_648( 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_79( 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 CALL SMUMPS_4( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF 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 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 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_MUMPS) 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 RINFOG =>id%RINFOG MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LP = id%ICNTL( 1 ) PROK = (MP.GT.0) PROKG = (MPG.GT.0 .and. id%MYID.eq.MASTER) 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) NB_RHSSKIPPED = 0 LSCAL = .FALSE. WORK_WCB_ALLOCATED = .FALSE. ICNTL21 = -99998 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) CALL ZMUMPS_710 (id, NB_INT,NB_CMPLX ) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K35_8 NB_BYTES_ON_ENTRY = NB_BYTES NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID .EQ. MASTER) THEN CALL ZMUMPS_807(id) id%KEEP(111) = id%ICNTL(25) id%KEEP(248) = id%ICNTL(20) ICNTL21 = id%ICNTL(21) IF (ICNTL21 .ne.0.and.ICNTL21.ne.1) ICNTL21=0 IF ( id%ICNTL(30) .NE.0 ) THEN id%KEEP(237) = 1 ELSE id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN id%KEEP(248)=1 ENDIF IF (id%KEEP(248) .ne.0.and.id%KEEP(248).ne.1) id%KEEP(248)=0 IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN id%KEEP(248) = 0 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN id%KEEP(235) = 0 ENDIF MTYPE = ICNTL( 9 ) 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(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 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(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) IF ( id%MYID .EQ. MASTER ) THEN 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 IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN 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 IF (KEEP(252).NE.0 .AND. ICNTL(9).NE.1) THEN 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 INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE INFO(2) = 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 IF ( (id%KEEP(237).EQ.0) ) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. ICNTL21==0) THEN CALL ZMUMPS_758 & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE 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 IF ((id%NZ_RHS.LE.0).AND.(KEEP(237).NE.0)) THEN 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 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 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 IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN IF (PROKG) THEN write(MPG,*)id%MYID, & " Incompatible values for sparse RHS ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 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 CALL ZMUMPS_634(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(111) .NE. 0 .AND. id%KEEP(50) .EQ. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' ERROR: null space not available for unsymmetric matrices' INFO(1) = -37 INFO(2) = 0 GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN 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 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 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 END IF IF (ICNTL21==1) THEN IF ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) THEN 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 (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 IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1) THEN 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 CALL ZMUMPS_769(id) END IF IF (id%INFO(1) .LT. 0) GOTO 333 333 CONTINUE CALL MUMPS_276( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 IF ((id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0)) THEN CALL MPI_BCAST(id%NZ_RHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (id%NZ_RHS.EQ.0) THEN IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN LIW_PASSED=max(1,KEEP(32)) IF (KEEP(89) .GT. 0) THEN CALL ZMUMPS_535( 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 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 IF ( PROKG ) THEN 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 WRITE (MPG, 153) KEEP(252) ENDIF ENDIF GOTO 90 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(111).NE.0)) THEN KEEP(242) = 0 ENDIF ENDIF INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN IF (LP.GT.0) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF NBT = 0 CALL MUMPS_733(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN IF (NBT.NE.0) THEN DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE id%Step2node(id%STEP(I)) = I ENDDO ENDIF NB_BYTES = NB_BYTES + int(NBT,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + int(NBT,8) * K34_8 ENDIF IF ( I_AM_SLAVE ) & CALL MUMPS_804(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 IF (id%MYID.EQ.MASTER) THEN IF( KEEP(111)==0 .AND. KEEP(248)==1 ) THEN NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) & NRHS_NONEMPTY = NRHS_NONEMPTY+1 ENDDO IF (NRHS_NONEMPTY.LE.0) THEN IF (LP.GT.0) & WRITE(LP,*) 'Internal error : NRHS_NONEMPTY=', & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF BUILD_POSINRHSCOMP = .TRUE. IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN BUILD_POSINRHSCOMP = .FALSE. ENDIF SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_275( & 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 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_275( & 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 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF IF (id%MYID .eq. MASTER) THEN KEEP(84) = ICNTL(27) IF (KEEP(252).NE.0) THEN 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 ENDIF ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (KEEP(201).GT.0) THEN IF (I_AM_SLAVE) THEN IF (KEEP(201).EQ.1 & .AND.KEEP(50).EQ.0 & .AND.KEEP(251).NE.2 & ) THEN OOC_NB_FILE_TYPE=2 ELSE OOC_NB_FILE_TYPE=1 ENDIF ENDIF 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 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 ) ENDIF IF ( I_AM_SLAVE ) THEN NB_K133 = 3 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 LWCB_MIN = NB_K133*KEEP(133)*NBRHS 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 IF (KEEP(201).EQ.0) THEN IF (ITMP8.NE.KEEP8(24)) THEN INFO(1) = -41 INFO(2) = id%LWK_USER GOTO 99 ENDIF ELSE KEEP8(24)=ITMP8 ENDIF MAXS = 0_8 IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_731(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ELSE IF (associated(id%S)) THEN MAXS = KEEP8(23) ELSE IF (KEEP(201).EQ.0) THEN WRITE(*,*) ' Working array S not allocated ', & ' on entry to solve phase (in core) ' CALL MUMPS_ABORT() ELSE IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ENDIF ALLOCATE (id%S(MAXS), stat = allocok) KEEP8(23)=MAXS IF ( allocok .GT. 0 ) THEN WRITE(*,*) ' Problem allocation of S at solve' INFO(1) = -13 CALL MUMPS_731(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) ENDIF ENDIF IF(KEEP(201).EQ.0)THEN LA = KEEP8(31) ELSE LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF IF ( MAXS-LA .GT. int(LWCB_MIN,8) ) THEN TMP_LWCB8 = min( MAXS - LA, int(huge(LWCB),8) ) LWCB = int( TMP_LWCB8, kind(LWCB) ) WORK_WCB => id%S(LA+1_8:LA+TMP_LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB = LWCB_MIN ALLOCATE(WORK_WCB(LWCB_MIN), stat = allocok) IF (allocok < 0 ) THEN INFO(1)=-13 INFO(2)=LWCB_MIN ENDIF WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(size(WORK_WCB),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF 99 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL ZMUMPS_590(LA) CALL ZMUMPS_586(id) IS_INIT_OOC_DONE = .TRUE. ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 IF (id%MYID .eq. MASTER) THEN IF ( (KEEP(242).NE.0) .or. (KEEP(243).NE.0) ) THEN IF ( (KEEP(237) .EQ.0) .and. (KEEP(111).EQ.0) ) THEN KEEP(242) = 0 KEEP(243) = 0 ENDIF ENDIF 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 WRITE (MPG, 153) KEEP(252) ENDIF ENDIF LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ERANAL = ((ICNTL(11) .GT. 0) .OR. (ICNTL(10) .GT. 0)) IF ( (KEEP(55).eq.0) .AND. KEEP(54).eq.0 .AND. & .NOT.associated(id%A) ) THEN ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. ELSE ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) ENDIF IF ((KEEP(111).NE.0).OR.(KEEP(237).NE.0).OR. & (KEEP(252).NE.0) ) THEN IF (ICNTL10 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF (ICNTL11 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. END IF IF (KEEP(221).NE.0) THEN IF (ICNTL10 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 (reduced RHS))' ENDIF IF (ICNTL11 .GT. 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 (reduced RHS)' ENDIF ICNTL10 = 0 ICNTL11 = 0 ERANAL = .FALSE. END IF IF ((ERANAL .AND. NBRHS > 1) .OR. ICNTL(21) > 0) THEN IF (ICNTL11 > 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to zero' ICNTL11=0 ENDIF IF (ICNTL10 > 0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to zero' ICNTL10=0 ENDIF ERANAL = .FALSE. ENDIF IF (ERANAL) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN WRITE(*,*) ' 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 IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 END IF 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(ERANAL,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) CALL MPI_BCAST(KEEP(242),1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(243),1,MPI_INTEGER,MASTER, & id%COMM,IERR) DO_PERMUTE_RHS = (KEEP(242).NE.0) IF ( KEEP(242).NE.0) THEN IF ((KEEP(237).EQ.0).AND.(KEEP(111).EQ.0)) THEN IF (MP.GT.0) THEN write(MP,*) ' Warning incompatible options ', & ' permute RHS reset to false ' ENDIF DO_PERMUTE_RHS = .FALSE. ENDIF ENDIF IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN 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 #if defined(check) IF ( id%MYID_NODES .EQ. MASTER ) THEN WRITE(*,*) " ES A-1 DO_Perm Interleave =" WRITE(*,144) id%KEEP(235), id%KEEP(237), & id%KEEP(242),id%KEEP(243) ENDIF #endif MSG_MAX_BYTES_SOLVE = ( 4 + KEEP(133) ) * KEEP(34) + & KEEP(133) * NBRHS * KEEP(35) & + 16 * KEEP(34) IF (KEEP(237).EQ.0) THEN 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 MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(35) ) ENDIF 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 (LP.GT.0) & 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 ) THEN ZMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL ZMUMPS_55( ZMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = ZMUMPS_LBUF_INT IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF ZMUMPS_LBUF = (MSG_MAX_BYTES_SOLVE + 2*KEEP(34) )*id%NSLAVES ZMUMPS_LBUF = min(ZMUMPS_LBUF, 100 000 000) ZMUMPS_LBUF = max(ZMUMPS_LBUF, & (MSG_MAX_BYTES_SOLVE+2*KEEP(34)) * min(id%NSLAVES,3)) ZMUMPS_LBUF = ZMUMPS_LBUF + KEEP(34) CALL ZMUMPS_53( ZMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = ZMUMPS_LBUF/KEEP(34) + 1 IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF ENDIF IF ( & ( id%MYID .NE. MASTER ) & .or. & ( 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. & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) & ) THEN ALLOCATE(RHS_MUMPS(id%N*NBRHS),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_MUMPS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N*NBRHS IF (LP > 0) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' GOTO 111 END IF ELSE RHS_MUMPS=>id%RHS ENDIF IF ( I_AM_SLAVE ) THEN LD_RHSCOMP = max(KEEP(89),1) IF (id%MYID.EQ.MASTER) THEN LD_RHSCOMP = max(LD_RHSCOMP, KEEP(247)) ENDIF IF (KEEP(221).EQ.2 .AND. KEEP(252).EQ.0) THEN IF (.NOT.associated(id%RHSCOMP)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF IF (.NOT.associated(id%POSINRHSCOMP)) THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF LENRHSCOMP = size(id%RHSCOMP) LD_RHSCOMP = LENRHSCOMP/id%NRHS ELSE IF (KEEP(221).EQ.1) THEN IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) ENDIF LENRHSCOMP = LD_RHSCOMP*id%NRHS ALLOCATE (id%RHSCOMP(LENRHSCOMP)) NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) ENDIF ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE LENRHSCOMP = LD_RHSCOMP*NBRHS IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) ENDIF ALLOCATE (id%RHSCOMP(LENRHSCOMP)) NB_BYTES = NB_BYTES + int(size(id%RHSCOMP),8)*K35_8 IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) ENDIF ALLOCATE (id%POSINRHSCOMP(KEEP(28)) ) NB_BYTES = NB_BYTES + int(size(id%POSINRHSCOMP),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF LIWK_SOLVE = 4 * KEEP(28) + 1 IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE( LIWK_SOLVE), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) 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) LIW = KEEP(32) 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) IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) ) THEN ALLOCATE(POSINRHSCOMP_N(id%N), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP.GT.0) WRITE(LP,*) & ' ERROR in ZMUMPS_301: allocating POSINRHSCOMP_N' INFO(1) = -13 INFO(2) = id%N GOTO 111 END IF NB_BYTES = NB_BYTES + int(size(POSINRHSCOMP_N),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) END IF ELSE LIW=0 END IF 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) & ) & .OR. ( ( KEEP(237).NE.0 ) .AND. (KEEP(23).NE.0) ) & ) 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 DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF 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 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif CALL MUMPS_276( 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 CALL MPI_BCAST(UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN 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 (LP > 0) 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 (LP > 0) 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 LIW_PASSED=max(1,LIW) IF (KEEP(89) .GT. 0) THEN CALL ZMUMPS_535( 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 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 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 40 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 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 IF ( ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) THEN 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 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 IF ( id%MYID .EQ. MASTER ) THEN 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 CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF ENDIF ENDIF IF ( KEEP(248)==1 ) THEN JEND_RHS = 0 IF (DO_PERMUTE_RHS) THEN 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 STRAT_PERMAM1 = KEEP(242) CALL MUMPS_780 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF 109 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (id%NSLAVES .EQ. 1) THEN IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF 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 IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_772 & (PERM_RHS, id%NRHS, id%N, id%KEEP(28), & id%PROCNODE_STEPS(1), id%STEP(1), id%NSLAVES, & id%Step2node(1), & IERR) ENDIF ENDIF ENDIF ENDIF IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) 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 ( & ( id%MYID .NE. MASTER ) & .or. & ( 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. & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) & ) THEN LD_RHS = id%N IBEG = 1 ELSE IF ( associated(id%RHS) ) THEN LD_RHS = max(id%LRHS, id%N) ELSE LD_RHS = id%N ENDIF IBEG = (BEG_RHS-1) * LD_RHS + 1 ENDIF JBEG_RHS = BEG_RHS IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 ) THEN JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN DO I=1, id%N RHS_MUMPS((PERM_RHS(JBEG_RHS) -1)*LD_RHS+I) & = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 CYCLE 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 DO I=1, id%N RHS_MUMPS((JBEG_RHS -1)*LD_RHS + I) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN DO I = 1, id%SIZE_SCHUR id%REDRHS((JBEG_RHS-1)*LD_REDRHS + I) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN IBEG = (JBEG_RHS-1) * LD_RHS + 1 ENDIF ENDIF CALL MPI_BCAST( JBEG_RHS,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0) THEN IBEG_REDRHS= (JBEG_RHS-1)*LD_REDRHS + 1 ELSE IBEG_REDRHS=-142424 ENDIF IF ( I_AM_SLAVE ) THEN IF ( KEEP(221).EQ.0 ) THEN IBEG_RHSCOMP= 1 ELSE IBEG_RHSCOMP= (JBEG_RHS-1)*LD_RHSCOMP + 1 ENDIF ELSE IBEG_RHSCOMP=-152525 ENDIF #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN IF (KEEP(248)==1) THEN NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 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 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)) & STOP_AT_NEXT_EMPTY_COL =.TRUE. IF (COLSIZE.GT.0) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN NBCOL_INBLOC = NBCOL_INBLOC -1 NBRHS_EFF = NBCOL EXIT ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NBCOL.NE.NBRHS_EFF) THEN WRITE(6,*) 'INTERNAL ERROR 1 in ZMUMPS_301 ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF 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) JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 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 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 IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN 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 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) 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 & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN 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 & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY & => 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 RHS_SPARSE_COPY = ONE ELSE IF (.NOT. LSCAL) 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)) 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 ENDIF IF (KEEP(23) .NE. 0) THEN IF (MTYPE .NE. 1) THEN IF (KEEP(248)==0) THEN ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF ( LP .GT. 0 ) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in ZMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF DO K = 1, NBRHS_EFF KDEC = IBEG+(K-1)*LD_RHS DO I = 1, id%N C_RW2(I)=RHS_MUMPS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) RHS_MUMPS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ELSE IPOS = 1 DO I=1, NBCOL_INBLOC 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 ENDIF ENDIF IF (ERANAL) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+(K-1)*LD_RHS DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = RHS_MUMPS(KDEC+I-1) END DO ENDDO ENDIF ENDIF IF (LSCAL) THEN IF (KEEP(248)==0) THEN IF (MTYPE .EQ. 1) THEN DO K =1, NBRHS_EFF KDEC = (K-1) * LD_RHS + IBEG - 1 DO I = 1, id%N RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * & id%ROWSCA(I) END DO ENDDO ELSE DO K =1, NBRHS_EFF KDEC = (K-1) * LD_RHS + IBEG - 1 DO I = 1, id%N RHS_MUMPS(KDEC+I) = RHS_MUMPS(KDEC+I) * & id%COLSCA(I) END DO ENDDO ENDIF ELSE KDEC=id%IRHS_PTR(JBEG_RHS) IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN RHS_SPARSE_COPY(IPOS) = id%ROWSCA(PERM_RHS(I)) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE DO K = 1, COLSIZE II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) 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 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 END IF ENDIF #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif 30 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF ( I_AM_SLAVE ) THEN IF ( (KEEP(111).NE.0) .OR. (KEEP(248).NE.0) .OR. & (KEEP(252).NE.0) ) THEN IF (BUILD_POSINRHSCOMP) THEN IF (KEEP(111).NE.0) THEN WHAT = 2 MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN WHAT = 0 MTYPE_LOC = 1 ELSE WHAT = 1 MTYPE_LOC = MTYPE ENDIF LIW_PASSED=max(1,LIW) IF (WHAT.EQ.0) THEN CALL ZMUMPS_639(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(1), IDUMMY, 1, MTYPE_LOC, & WHAT ) ELSE CALL ZMUMPS_639(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(1), POSINRHSCOMP_N(1), & id%N, MTYPE_LOC, & WHAT ) ENDIF BUILD_POSINRHSCOMP = .FALSE. ENDIF ENDIF ENDIF 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(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN 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 #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0)) THEN IF (KEEP(248) == 0) THEN IF ( .NOT.I_AM_SLAVE ) THEN CALL ZMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) BUILD_POSINRHSCOMP=.FALSE. ELSE LIW_PASSED = max( LIW, 1 ) CALL ZMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), & BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) BUILD_POSINRHSCOMP=.FALSE. ENDIF IF (INFO(1).LT.0) GOTO 90 ELSE CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER) 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. 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) 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 45 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_DOUBLE_COMPLEX, & 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 IF ( I_AM_SLAVE ) THEN IF (KEEP(237).NE.0) THEN K=1 RHS_MUMPS(1:NBRHS_EFF*LD_RHS) = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IF (POSINRHSCOMP_N(J).NE.0) THEN RHS_MUMPS((K-1) * LD_RHS + J) = & RHS_SPARSE_COPY(IPOS) ENDIF K = K + 1 IPOS = IPOS + COLSIZE ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'INTERNAL ERROR 2 in ZMUMPS_301 ', & K, NBRHS_EFF call MUMPS_ABORT() ENDIF ELSE IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0)) THEN 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 DO K = 1, NBCOL_INBLOC KDEC = (K-1) * LD_RHS + IBEG - 1 RHS_MUMPS(KDEC+1:KDEC+id%N) = ZERO DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IF (POSINRHSCOMP_N(I).NE.0) THEN RHS_MUMPS(KDEC+I)= RHS_SPARSE_COPY(IZ) ENDIF ENDDO ENDDO END IF ENDIF ENDIF ELSE IF (I_AM_SLAVE) THEN IF (KEEP(111).NE.0) THEN 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 IEND_GLOB_DEF = id%KEEP(112) id%KEEP(235) = 1 DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN 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+K35_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN 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 50 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 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) RHS_MUMPS( IBEG : & (IBEG + (NBRHS_EFF)*LD_RHS -1) ) = ZERO ENDIF DO K=1, NBRHS_EFF KDEC = (K-1) *LD_RHSCOMP id%RHSCOMP(KDEC+1:KDEC+LD_RHSCOMP)=ZERO END DO IF ((KEEP(235).NE.0).AND. INTERLEAVE_PAR) THEN DO I=IBEG_GLOB_DEF,IEND_GLOB_DEF IF (id%MYID_NODES .EQ. MAP_PIVNUL_LIST(I) ) THEN JJ= POSINRHSCOMP_N(PERM_PIV_LIST(I)) IF (JJ.GT.LD_RHSCOMP) THEN WRITE(6,*) ' Internal ERROR JJ, LD_RHSCOMP=', & JJ, LD_RHSCOMP ENDIF IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN id%RHSCOMP(IBEG_RHSCOMP -1+ & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = & cmplx(abs(id%DKEEP(2)),kind=kind(id%RHSCOMP)) ELSE id%RHSCOMP(IBEG_RHSCOMP -1+ & (I-IBEG_GLOB_DEF)*LD_RHSCOMP + JJ) = ONE ENDIF ENDIF ENDIF ENDDO ELSE DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) JJ= POSINRHSCOMP_N(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP & + JJ) = cmplx(id%DKEEP(2),kind=kind(id%RHSCOMP)) ELSE id%RHSCOMP(IBEG_RHSCOMP-1+(I-IBEG_GLOB_DEF)*LD_RHSCOMP & + JJ) = ONE ENDIF ENDIF ENDDO ENDIF IF ( KEEP(17).NE.0 .and. id%MYID_NODES.EQ.MASTER_ROOT) THEN IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -90999 ENDIF ELSE ENDIF ENDIF IF ( I_AM_SLAVE ) THEN LWCB_SOL_C = LWCB IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN IF ( associated(id%root%RHS_CNTR_MASTER_ROOT) ) THEN PTR_RHS_ROOT => id%root%RHS_CNTR_MASTER_ROOT LPTR_RHS_ROOT = size(id%root%RHS_CNTR_MASTER_ROOT) ELSE LPTR_RHS_ROOT = NBRHS_EFF * SIZE_ROOT IPT_RHS_ROOT = LWCB - LPTR_RHS_ROOT + 1 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1 IPT_RHS_ROOT = LWCB PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB) LWCB_SOL_C = LWCB_SOL_C - LPTR_RHS_ROOT ENDIF ENDIF IF (KEEP(221) .EQ. 2 ) THEN IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE IF ( id%MYID .EQ. MASTER) THEN IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 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 II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 ENDIF ENDIF IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF ((id%KEEP(235).EQ.0).and.(id%KEEP(237).EQ.0) ) THEN PRUNED_SIZE_LOADED = 0_8 CALL ZMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, & IWCB, LIWCB, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%NA(1),id%LNA,id%NE_STEPS(1), SRW3, MTYPE, & ICNTL(1), 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, id%PROCNODE_STEPS(1), & id%NSLAVES, INFO(1), KEEP(1), KEEP8(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(1), BUILD_POSINRHSCOMP & , 1 , 1 , 1 & , 1 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & ) ELSE IF ((KEEP(235).NE.0).AND.KEEP(221).NE.2.AND. & KEEP(111).EQ.0) THEN DO K=1, NBRHS_EFF DO I=1, LD_RHSCOMP id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO ENDDO ENDDO ELSEIF (KEEP(237).NE.0) THEN DO K=1, NBRHS_EFF DO I=1, LD_RHSCOMP id%RHSCOMP(IBEG_RHSCOMP+(K-1)*LD_RHSCOMP+I-1)= ZERO ENDDO ENDDO ENDIF IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF CALL ZMUMPS_245(id%root, id%N, id%S(1), LA_PASSED, & IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, id%NA(1),id%LNA, & id%NE_STEPS(1), SRW3, MTYPE, ICNTL(1), 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, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1),KEEP(1),KEEP8(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(1), BUILD_POSINRHSCOMP, & NZ_THIS_BLOCK, NBCOL_INBLOC, id%NRHS, & JBEG_RHS , id%Step2node(1), id%KEEP(28), IRHS_SPARSE_COPY(1), & IRHS_PTR_COPY(1), & size(PERM_RHS), PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV & ) ENDIF END IF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LP.GT.0) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LP.GT.0) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF IF (INFO(1).LT.0) GO TO 90 IF ( KEEP(221) .EQ. 1 ) THEN IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS -1 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE IF ( id%MYID .EQ. MASTER ) THEN IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+(K-1)*LD_REDRHS 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 II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN 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 ENDIF ENDIF IF ( KEEP(221) .NE. 1 ) THEN IF (ICNTL21 == 0) THEN IF ((.NOT. I_AM_SLAVE).AND.KEEP(237).EQ.0) THEN ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) IF (allocok > 0) THEN ALLOCATE( CWORK(KEEP(247)), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=KEEP(247) ENDIF ENDIF ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) 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 ( .NOT.I_AM_SLAVE ) THEN IF (KEEP(237).EQ.0) THEN CALL ZMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & 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) & ) DEALLOCATE( CWORK ) ELSE CALL ZMUMPS_812(id%NSLAVES,id%N, & id%MYID, id%COMM, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) & ,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 & ) ENDIF ELSE IF (KEEP(237).EQ.0) THEN CALL ZMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & 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, & id%RHSCOMP(1), LENRHSCOMP, & LSCAL, PT_SCALING(1), size(PT_SCALING) & ) ELSE CALL ZMUMPS_812(id%NSLAVES,id%N, & id%MYID, id%COMM, & RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%KEEP(1), id%BUFR(1), id%LBUFR, id%LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) & , 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), POSINRHSCOMP_N, & id%N & ) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN 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 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 1 gather sol_driver" CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ELSE 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 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 2 gather sol_driver" CALL MUMPS_ABORT() ENDIF ENDDO id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDDO ENDIF ENDIF ELSE IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) IF ( KEEP(89) .GT. 0 ) THEN CALL ZMUMPS_532(id%NSLAVES, & id%N, id%MYID_NODES, & MTYPE, RHS_MUMPS(IBEG), LD_RHS, NBRHS_EFF, & id%ISOL_loc(1), & id%SOL_loc(1), 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 ) ENDIF ENDIF ENDIF ENDIF IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN DO I = 1, ICNTL10 write(*,*) 'FIXME: to be implemented' END DO END IF IF (ERANAL) THEN IF ((ICNTL10 .GT. 0) .AND. (ICNTL11 .GT. 0)) THEN IF (id%MYID .EQ. MASTER) THEN GIVSOL = .FALSE. IF (MP .GT. 0) WRITE( MP, 170 ) ALLOCATE(R_RW1(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 776 ENDIF ALLOCATE(C_RW2(id%N),stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 776 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) END IF 776 CONTINUE CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL ZMUMPS_278( ICNTL(9), id%N, id%NZ, id%A(1), & id%IRN(1), id%JCN(1), & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, & KEEP(1),KEEP8(1) ) ELSE CALL ZMUMPS_121( ICNTL(9), id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & RHS_MUMPS(IBEG), SAVERHS, R_RW1, C_RW2, & KEEP(1),KEEP8(1) ) ENDIF END IF ELSE CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_DOUBLE_COMPLEX, MASTER, & id%COMM, IERR ) ALLOCATE( C_LOCWK54( id%N ), stat =allocok ) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N endif CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL ZMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_RW2, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C_RW2 = SAVERHS - C_RW2 ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF NB_BYTES = NB_BYTES - int(size(C_LOCWK54),8)*K35_8 DEALLOCATE( C_LOCWK54 ) ALLOCATE( R_LOCWK54( id%N ), stat =allocok ) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N endif CALL MUMPS_276(ICNTL(1), INFO(1), id%COMM, id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NZ_loc .NE. 0 ) THEN CALL ZMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1)) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_RW1, & 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 NB_BYTES = NB_BYTES - int(size(R_LOCWK54),8)*K16_8 DEALLOCATE( R_LOCWK54 ) END IF IF ( id%MYID .EQ. MASTER ) THEN CALL ZMUMPS_205(ICNTL(9),INFO(1),id%N,id%NZ, & RHS_MUMPS(IBEG), SAVERHS,R_RW1,C_RW2,GIVSOL, & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MP,ICNTL(1), & KEEP(1),KEEP8(1)) NB_BYTES = NB_BYTES - int(size(R_RW1),8)*K16_8 & - int(size(C_RW2),8)*K35_8 DEALLOCATE(R_RW1) DEALLOCATE(C_RW2) END IF END IF IF ( PROK .AND. ICNTL10 .GT. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .GT. 0 ) WRITE( MPG, 270 ) 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( 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 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 NITREF = ICNTL10 JOBIREF= ICNTL11 IF ( PROKG .AND. ICNTL10 .GT. 0 ) & WRITE( MPG, 240) 'MAXIMUM NUMBER OF STEPS =', NITREF DO I = 1, id%N D( I ) = RONE END DO 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 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 22 CONTINUE IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .eq. 0 ) THEN IF (KEEP(55).NE.0) THEN CALL ZMUMPS_119(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE IF ( MTYPE .eq. 1 ) THEN CALL ZMUMPS_207 & ( id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) ELSE CALL ZMUMPS_207 & ( id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) END IF ENDIF ENDIF END IF ELSE IF ( KASE .eq. 0 ) THEN IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL ZMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE CALL ZMUMPS_207(id%A_loc(1), & id%NZ_loc, 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 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 END IF END IF IF ( id%MYID .eq. MASTER ) THEN ARRET = CNTL(2) IF (ARRET .LT. 0.0D0) THEN ARRET = sqrt(epsilon(0.0D0)) END IF CALL ZMUMPS_206(id%NZ,id%N,SAVERHS,RHS_MUMPS(IBEG), & C_Y, D, R_W, C_W, & IW1, KASE,RINFOG(7), & RINFOG(9), JOBIREF, RINFOG(10), NITREF, NOITER, MP, & KEEP(1),KEEP8(1), ARRET ) END IF IF ( KEEP(54) .ne. 0 ) THEN CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) END IF IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .eq. 14 ) THEN IF (KEEP(55).NE.0) THEN CALL ZMUMPS_122( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%NA_ELT, id%A_ELT(1), & SAVERHS, RHS_MUMPS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL ZMUMPS_208 & (id%A(1), id%NZ, id%N, id%IRN(1), id%JCN(1), SAVERHS, & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL ZMUMPS_208 & (id%A(1), id%NZ, id%N, id%JCN(1), id%IRN(1), SAVERHS, & RHS_MUMPS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) END IF ENDIF GOTO 22 END IF END IF ELSE IF ( KASE.eq.14 ) THEN CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_DOUBLE_COMPLEX, MASTER, & id%COMM, IERR ) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL ZMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(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 IF ( I_AM_SLAVE .and. id%NZ_loc .NE. 0 ) THEN CALL ZMUMPS_193( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(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) END IF GOTO 22 END IF END IF IF ( id%MYID .eq. MASTER ) THEN IF ( KASE .GT. 0 ) THEN IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF END IF END IF CALL MPI_BCAST( KASE , 1, MPI_INTEGER, MASTER, & id%COMM, IERR) CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) IF ( KASE .GT. 0 ) THEN BUILD_POSINRHSCOMP=.FALSE. IF ( .NOT.I_AM_SLAVE ) THEN CALL ZMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, C_Y(1), id%N, 1, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), KDUMMY, 1, BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) ELSE LIW_PASSED = max( LIW, 1 ) CALL ZMUMPS_638(id%NSLAVES,id%N, id%MYID, id%COMM, & MTYPE, C_Y(1), id%N, 1, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), id%POSINRHSCOMP(1), KEEP(28), & BUILD_POSINRHSCOMP, & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) CALL ZMUMPS_245( id%root, id%N, id%S(1), LA_PASSED, & id%IS(1), LIW_PASSED, WORK_WCB(1), LWCB_SOL_C, IWCB, LIWCB, C_Y, & id%N, NBRHS_EFF, id%NA(1), id%LNA, id%NE_STEPS(1), SRW3, SOLVET, & ICNTL(1), 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, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(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(1), BUILD_POSINRHSCOMP & , 1 , 1 , 1 & , 1 & , IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & ) END IF IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 IF ( .NOT. I_AM_SLAVE .AND. INFO(1) .GE. 0) THEN ALLOCATE( CWORK(KEEP(247)*NBRHS_EFF), stat=allocok) IF (allocok > 0) THEN ALLOCATE( CWORK(KEEP(247)), stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=KEEP(247) ENDIF ENDIF ENDIF 89 CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GO TO 90 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 ) IF ( .NOT. I_AM_SLAVE ) THEN CALL ZMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & SOLVET, C_Y, id%N, NBRHS_EFF, & 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, size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING)) DEALLOCATE( CWORK ) ELSE CALL ZMUMPS_521(id%NSLAVES,id%N, & id%MYID, id%COMM, & SOLVET, C_Y, id%N, NBRHS_EFF, & 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, & id%RHSCOMP(1), LENRHSCOMP, & LSCAL, PT_SCALING(1), size(PT_SCALING)) ENDIF GO TO 22 ELSEIF ( KASE .LT. 0 ) THEN INFO( 1 ) = INFO( 1 ) + 8 END IF IF ( id%MYID .eq. MASTER ) THEN NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(D ),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W,D) DEALLOCATE(IW1) ENDIF IF ( PROKG ) THEN IF (NITREF.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, 141 ) 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS &=', NOITER ENDIF ENDIF IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF END IF IF ( PROK .AND. ICNTL10 .GT.0 ) WRITE( MP, 131 ) IF (ICNTL11 .GT. 0) THEN IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL ZMUMPS_278( MTYPE, id%N, id%NZ, id%A(1), & id%IRN(1), id%JCN(1), & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) ELSE CALL ZMUMPS_121( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%NA_ELT, id%A_ELT(1), & RHS_MUMPS(IBEG), SAVERHS, R_Y, C_W, KEEP(1),KEEP8(1)) ENDIF END IF ELSE CALL MPI_BCAST( RHS_MUMPS(IBEG), id%N, & MPI_DOUBLE_COMPLEX, MASTER, & id%COMM, IERR ) IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL ZMUMPS_192( id%N, id%NZ_loc, & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_MUMPS(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_W, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C_W = SAVERHS - C_W ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF IF ( I_AM_SLAVE .and. & id%NZ_loc .NE. 0 ) THEN CALL ZMUMPS_207(id%A_loc(1), & id%NZ_loc, id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_Y, & 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 END IF IF (id%MYID .EQ. MASTER) THEN IF ((MPG .GT. 0) .AND. (NITREF .GT. 0)) WRITE( MPG, 65 ) IF ((MPG .GT. 0) .AND. (NITREF .LE. 0)) WRITE( MPG, 170 ) GIVSOL = .FALSE. CALL ZMUMPS_205(MTYPE,INFO(1),id%N,id%NZ,RHS_MUMPS(IBEG), & SAVERHS,R_Y,C_W,GIVSOL, & RSOL,RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) &'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', RINFOG(7) WRITE( MPG, 115 ) &'------(8):---------------------------- (W2)=', RINFOG(8) 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 IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) 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) END IF IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0 .AND. KEEP(237).EQ.0 ) THEN IF ((KEEP(221).NE.1 .AND. ICNTL(9) .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN ALLOCATE( C_RW1( id%N ),stat =allocok ) 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 KDEC = (K-1)*LD_RHS+IBEG-1 DO 70 I = 1, id%N C_RW1(I) = RHS_MUMPS(KDEC+I) 70 CONTINUE DO 80 I = 1, id%N JPERM = id%UNS_PERM(I) RHS_MUMPS( KDEC+JPERM ) = C_RW1( I ) 80 CONTINUE END DO DEALLOCATE( C_RW1 ) END IF END IF IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1 & .and. KEEP(237).EQ.0 ) THEN 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) & (RHS_MUMPS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN BEG_RHS = BEG_RHS + NBRHS_EFF ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF ENDDO IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) & .AND. ( KEEP(237).EQ.0 ) & .AND. ( ICNTL21.EQ.0 ) & .AND. ( KEEP(221) .NE.1 ) & .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 RHS_MUMPS((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 RHS_MUMPS((JBEG_NEW -1)*LD_RHS + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF 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 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 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 JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,LD_RHSCOMP id%RHSCOMP((JBEG_NEW -1)*LD_RHSCOMP + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF id%INFO(26) = int(NB_BYTES_MAX / 1000000_8, 4) CALL MUMPS_243( 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 90 CONTINUE IF (INFO(1) .LT.0 ) THEN ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL ZMUMPS_582(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_276( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF 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 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(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF CALL ZMUMPS_57( IERR ) CALL ZMUMPS_59( IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF IF ( & ( & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & .and. ICNTL21.ne.0 ) & .or. & ( KEEP(237).NE.0 ) & ) & THEN IF ( I_AM_SLAVE ) THEN IF (associated(RHS_MUMPS) ) THEN NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 DEALLOCATE(RHS_MUMPS) ENDIF ENDIF ENDIF NULLIFY(RHS_MUMPS) ELSE IF (associated(RHS_MUMPS)) THEN NB_BYTES = NB_BYTES - int(size(RHS_MUMPS),8)*K35_8 DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) END IF END IF IF (I_AM_SLAVE) THEN IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K35_8 DEALLOCATE(SRW3) ENDIF IF (allocated(POSINRHSCOMP_N)) THEN NB_BYTES = NB_BYTES - int(size(POSINRHSCOMP_N),8)*K34_8 DEALLOCATE(POSINRHSCOMP_N) ENDIF IF (LSCAL .AND. ICNTL21==1) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF IF (WK_USER_PROVIDED) THEN NULLIFY(id%S) ELSE IF (associated(id%S).AND.KEEP(201).GT.0) THEN 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 IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%RHSCOMP),8)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) ENDIF IF (associated(id%POSINRHSCOMP)) THEN NB_BYTES = NB_BYTES - int(size(id%POSINRHSCOMP),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP) NULLIFY(id%POSINRHSCOMP) ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K35_8 DEALLOCATE( WORK_WCB ) ENDIF NULLIFY( WORK_WCB ) ENDIF RETURN 65 FORMAT (//' ERROR ANALYSIS AFTER ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' VECTOR SOLUTION FOR COLUMN ',I12) 115 FORMAT(1X, A44,1P,D9.2) 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, A42,I4) END SUBROUTINE ZMUMPS_301 SUBROUTINE ZMUMPS_245(root, N, A, LA, IW, LIW, W, LWC, & IWCB,LIWW,RHS,LRHS,NRHS,NA,LNA,NE_STEPS, W2, & MTYPE, ICNTL, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1,LIW1, & PROCNODE_STEPS, SLAVEF, & INFO, KEEP,KEEP8, 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, BUILD_POSINRHSCOMP & , 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 & ) 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 LWC,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 LRHS, NRHS, LRHSCOMP COMPLEX(kind=8) A(LA), W(LWC), RHS(LRHS,NRHS), & W2(KEEP(133)), & RHSCOMP(LRHSCOMP,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP(KEEP(28)) 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 LPTR_RHS_ROOT COMPLEX(kind=8) PTR_RHS_ROOT(LPTR_RHS_ROOT) LOGICAL BUILD_POSINRHSCOMP INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,LPANEL_POS INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB,PTRACB INTEGER MTYPE_LOC 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' EXTERNAL ZMUMPS_248, ZMUMPS_249 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) 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 INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_808 EXTERNAL :: MUMPS_808 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 NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) PTRACB = PTRICB + KEEP(28) IPOOL = PTRACB + 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 in ZMUMPS_245", & 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 ( 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_276(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_276(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_276(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 #if defined(NOT_USED) IF ( KEEP(201).GT.0) THEN CALL ZMUMPS_789(KEEP(28), & KEEP(38), KEEP(20) ) ENDIF #endif nb_nodes_RHS = 0 #if defined(check) WRITE(*,*) "NBCOL_INBLOC=",NBCOL_INBLOC WRITE(*,*) "JBEG SIZE=",JBEG_RHS, SIZE(IRHS_PTR) #endif 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_276(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_797( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_797( & .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_809(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_808 & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_802( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) 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_583(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_248(N, A(1), LA, IW(1), LIW, W(1), & LWC, RHS, LRHS, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, & NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP,KEEP8, & 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 & ) 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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(I.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_248(N, A(1), LA, IW(1), LIW, W(1), & LWC, RHS, LRHS, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP,BUILD_POSINRHSCOMP, & Pruned_SONS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF,INFO, & KEEP,KEEP8, & 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 & ) DEALLOCATE(prun_NA) ENDIF BUILD_POSINRHSCOMP = .FALSE. #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM ZMUMPS_248,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) 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)) 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 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_798( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_798( & .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_809(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_808 & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_803( & 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_584(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_276(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 ( ( 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 write(6,*) " CPA to be double checked " 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_643( & 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_643', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL ZMUMPS_286( 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)) IF(KEEP(201).GT.0)THEN CALL ZMUMPS_598(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after ZMUMPS_598 ', & 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 defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_276(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(111).NE.0) & I_WORKED_ON_ROOT = .FALSE. 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_797( & .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_276(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_276(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_276(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL MUMPS_797( & .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_809(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_808 & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL MUMPS_802( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL ZMUMPS_584(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.SPECIAL_ROOT_REACHED ) THEN PTR_RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO 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_249( N, A, LA, IW, LIW, W(1), LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, & W2, NE_STEPS, NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, & 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) 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_249( N, A, LA, IW, LIW, W(1), LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & IW1(PTRICB),IW1(PTRACB),IWCB,LIWW, & W2, NE_STEPS, prun_NA, LNA, STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES,MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP,KEEP8, & 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) ENDIF #if defined(V_T) CALL VTEND(back_soln,ierr) #endif ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N WRITE (MP,99992) IF (N.GT.0) WRITE (MP,99993) (RHS(I,1),I=1,K) IF (N.GT.0.and.NRHS>1) & WRITE (MP,99994) (RHS(I,2),I=1,K) 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_245 SUBROUTINE ZMUMPS_521(NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NRHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, & LSCAL, SCALING, LSCALING) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, LCWORK COMPLEX(kind=8) RHS (LRHS, NRHS) 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) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER STATUS(MPI_STATUS_SIZE), IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER SK38, SK20 INTEGER, PARAMETER :: FIN = -1 INTEGER, PARAMETER :: yes = 1 INTEGER, PARAMETER :: no = 0 INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist(:) INTEGER :: ONE_PACK INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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 DO J=1, NRHS DO I=1,N RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDDO ENDIF RETURN ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.0) THEN DO J=1, NRHS IF ( I_AM_SLAVE ) THEN CALL MPI_SEND(RHS(1, J), N, MPI_DOUBLE_COMPLEX, MASTER, & GatherSol, COMM, IERR) & ELSE CALL MPI_RECV(RHS(1, J), N, MPI_DOUBLE_COMPLEX, & 1, & GatherSol, COMM, STATUS, IERR ) IF (LSCAL) THEN DO I=1,N RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDIF ENDIF ENDDO RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .GE. MAXSurf) THEN ONE_PACK = yes ELSE IF (LCWORK .GE. MAXNPIV_estim) THEN ONE_PACK = no ELSE WRITE(*,*) & "Internal error 2 in ZMUMPS_521:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (ONE_PACK .EQ. no .AND. I_AM_SLAVE) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_521:", & TYPE_PARAL, LCWORK, KEEP(246),KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (TYPE_PARAL .EQ. 0) &CALL MPI_BCAST(ONE_PACK, 1, MPI_INTEGER, & MASTER, COMM, IERR) 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_521 ' 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_275(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.AND.LSCAL) & CALL ZMUMPS_522 ( ONE_PACK, .TRUE. ) ELSE IF (NPIV.GT.0) & CALL ZMUMPS_522 ( ONE_PACK, .FALSE.) ENDIF ENDIF ENDDO CALL ZMUMPS_523() 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 (ONE_PACK.EQ.yes) THEN CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV*NRHS, MPI_DOUBLE_COMPLEX, & COMM, IERR) IF (LSCAL) THEN DO J=1, NRHS DO I=1,NPIV RHS(IROWlist(I),J)= & CWORK(I+(J-1)*NPIV)*SCALING(IROWlist(I)) ENDDO END DO ELSE DO J=1, NRHS DO I=1,NPIV RHS(IROWlist(I),J)= CWORK(I+(J-1)*NPIV) ENDDO END DO ENDIF ELSE DO J=1,NRHS 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),J)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE DO I=1,NPIV RHS(IROWlist(I),J)=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_522 ( ONE_PACK, SCALE_ONLY ) INTEGER, intent(in) :: ONE_PACK LOGICAL, intent(in) :: SCALE_ONLY INTEGER III IF (SCALE_ONLY) THEN DO II=1,NPIV I=IW(J1+II-1) DO J=1, NRHS RHS(I,J) = RHS(I,J)*SCALING(I) ENDDO ENDDO RETURN ENDIF DO II=1,NPIV I=IW(J1+II-1) DO J=1, NRHS CWORK(II+(J-1)*NPIV) = RHS(I,J) ENDDO ENDDO 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 ) IF (ONE_PACK.EQ.yes) THEN CALL MPI_PACK(CWORK(1), NPIV*NRHS, MPI_DOUBLE_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ELSE III = 1 DO J=1,NRHS CALL MPI_PACK(CWORK(III), NPIV, MPI_DOUBLE_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) III =III+NPIV ENDDO ENDIF N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL ZMUMPS_523() END IF RETURN END SUBROUTINE ZMUMPS_522 SUBROUTINE ZMUMPS_523() 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_523 END SUBROUTINE ZMUMPS_521 SUBROUTINE ZMUMPS_812(NSLAVES, N, MYID, COMM, & RHS, LRHS, NRHS, 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_N, LPOS_N ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHS, LPOS_N COMPLEX(kind=8) RHS (LRHS, NRHS) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSCOMP_N(LPOS_N) 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 INTEGER STATUS(MPI_STATUS_SIZE), 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) IF (POSINRHSCOMP_N(I).NE.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHS(I,K)*SCALING(I) ELSE RHS_SPARSE_COPY(IZ)=RHS(I,K) ENDIF ENDIF ENDDO K = K + 1 ENDDO RETURN ENDIF IF (I_AM_SLAVE) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IF (POSINRHSCOMP_N(I).NE.0) THEN RHS_SPARSE_COPY(IZ)=RHS(I,K) ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_DOUBLE_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in ZMUMPS_812 ' 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) IF (POSINRHSCOMP_N(II).NE.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 IF (LSCAL) & CALL ZMUMPS_813 ( .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_813 ( .FALSE. ) ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL ZMUMPS_814() 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_813 ( 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_814() END IF RETURN END SUBROUTINE ZMUMPS_813 SUBROUTINE ZMUMPS_814() 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_814 END SUBROUTINE ZMUMPS_812 SUBROUTINE ZMUMPS_535(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_275 EXTERNAL MUMPS_275 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_275( 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_535 SUBROUTINE ZMUMPS_532( & SLAVEF, N, MYID_NODES, & MTYPE, RHS, LD_RHS, NRHS, & ISOL_LOC, SOL_LOC, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & scaling_data, LSCAL, NB_RHSSKIPPED) 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, NRHS, LD_RHS INTEGER LSOL_LOC, BEG_RHS, NB_RHSSKIPPED INTEGER ISOL_LOC(LSOL_LOC) COMPLEX(kind=8) SOL_LOC( LSOL_LOC, BEG_RHS+NRHS+NB_RHSSKIPPED-1) COMPLEX(kind=8) RHS( LD_RHS , NRHS) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER JJ, J1, ISTEP, K, JEMPTY, JEND INTEGER IPOS, LIELL, NPIV LOGICAL ROOT COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NRHS-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(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 DO JJ=J1,J1+NPIV-1 K=K+1 IF (NB_RHSSKIPPED.GT.0) & SOL_LOC(K, BEG_RHS:JEMPTY) = ZERO IF (LSCAL) THEN SOL_LOC(K,JEMPTY+1:JEND) = & scaling_data%SCALING_LOC(K)*RHS(IW(JJ),1:NRHS) ELSE SOL_LOC(K,JEMPTY+1:JEND) = & RHS(IW(JJ),1:NRHS) ENDIF ENDDO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_532 SUBROUTINE ZMUMPS_638 & (NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NRHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP, LENPOSINRHSCOMP, & BUILD_POSINRHSCOMP, ICNTL, INFO) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, LENPOSINRHSCOMP INTEGER ICNTL(40), INFO(40) COMPLEX(kind=8) RHS (LRHS, NRHS) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N), POSINRHSCOMP(LENPOSINRHSCOMP) LOGICAL BUILD_POSINRHSCOMP INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS 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, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER STATUS(MPI_STATUS_SIZE), IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER SK38, SK20, IPOSINRHSCOMP INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 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) ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_276(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) 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 ) RHS( BUF_INDX(I), K ) = ZERO 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 IF (I_AM_SLAVE) THEN IF (BUILD_POSINRHSCOMP) THEN IPOSINRHSCOMP = 1 POSINRHSCOMP = -9678 ENDIF IF (MYID.NE.MASTER) RHS = ZERO DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(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 (BUILD_POSINRHSCOMP) THEN POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF IF (MYID.NE.MASTER) THEN 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_640() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL ZMUMPS_640() ENDIF DEALLOCATE (BUF_INDX, BUF_RHS) RETURN CONTAINS SUBROUTINE ZMUMPS_640() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX(I) DO K = 1, NRHS RHS( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO BUF_EFFSIZE = 0 RETURN END SUBROUTINE ZMUMPS_640 END SUBROUTINE ZMUMPS_638 SUBROUTINE ZMUMPS_639 & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP, POSINRHSCOMP_N, LPIRC_N, MTYPE, & WHAT ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID_NODES, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N), POSINRHSCOMP(KEEP(28)) INTEGER LPIRC_N, WHAT, MTYPE INTEGER POSINRHSCOMP_N(LPIRC_N) INTEGER ISTEP INTEGER NPIV INTEGER SK38, SK20, IPOS, LIELL INTEGER JJ, J1 INTEGER IPOSINRHSCOMP INCLUDE 'mumps_headers.h' INTEGER MUMPS_275 EXTERNAL MUMPS_275 IF (WHAT .NE. 0.AND. WHAT.NE.1.AND.WHAT.NE.2) THEN WRITE(*,*) "Internal error in ZMUMPS_639" CALL MUMPS_ABORT() ENDIF 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 IPOSINRHSCOMP = 1 POSINRHSCOMP = -9678 IF (WHAT .NE. 0) THEN POSINRHSCOMP_N = 0 ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_275(PROCNODE_STEPS(ISTEP), & NSLAVES)) THEN IPOS = PTRIST(ISTEP) NPIV = IW(IPOS+3+KEEP(IXSZ)) POSINRHSCOMP(ISTEP) = IPOSINRHSCOMP IF (WHAT .NE. 0) 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)) ENDIF IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_N(IW(JJ)) = IPOSINRHSCOMP+JJ-J1 END DO ENDIF IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_639 SUBROUTINE ZMUMPS_248(N, A, LA, IW, LIW, WCB, LWCB, & RHS, LRHS, NRHS, & PTRICB, IWCB, LIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, BUILD_POSINRHSCOMP, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, & NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, INFO, & KEEP,KEEP8, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) USE ZMUMPS_OOC IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER N, LIW, LWCB, LPOOL, LIWCB, LNA INTEGER SLAVEF, MYLEAF, COMM, MYID INTEGER INFO( 40 ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER LRHS, NRHS COMPLEX(kind=8) A( LA ), RHS( LRHS, NRHS ), WCB( LWCB ) INTEGER 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) ) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSCOMP(KEEP(28)), LRHSCOMP LOGICAL BUILD_POSINRHSCOMP COMPLEX(kind=8) RHSCOMP( LRHSCOMP, NRHS ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGSOU, DUMMY(1) LOGICAL FLAG INTEGER NBFIN, MYROOT INTEGER POSIWCB,POSWCB,PLEFTWCB INTEGER INODE INTEGER RHSCOMPFREEPOS INTEGER I INTEGER III, NBROOT,LEAF LOGICAL BLOQ EXTERNAL MUMPS_275 INTEGER MUMPS_275 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1 IF (BUILD_POSINRHSCOMP) RHSCOMPFREEPOS= 1 DO I = 1, KEEP(28) NSTK_S(I) = NE_STEPS(I) ENDDO PTRICB = 0 CALL MUMPS_362(N, LEAF, NBROOT, MYROOT, MYID, & SLAVEF, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) NBFIN = SLAVEF IF ( MYROOT .EQ. 0 ) THEN NBFIN = NBFIN - 1 DUMMY(1) = 1 CALL ZMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF) END IF MYLEAF = LEAF - 1 III = 1 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL ZMUMPS_574 & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF BLOQ = ( ( III .EQ. LEAF ) & ) CALL ZMUMPS_303( 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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL ZMUMPS_574 & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE CALL ZMUMPS_302( 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, RHS, LRHS, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & MYROOT, INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL ZMUMPS_150( MYID,COMM,BUFR, & LBUFR,LBUFR_BYTES ) RETURN END SUBROUTINE ZMUMPS_248 RECURSIVE SUBROUTINE ZMUMPS_323 & ( 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, STEP, PROCNODE_STEPS, & RHS, LRHS & ) USE ZMUMPS_OOC USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8) :: LA INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) 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 ) INTEGER LRHS COMPLEX(kind=8) RHS(LRHS, NRHS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, K, JJ INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PTRX, PTRY, PDEST, I INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG EXTERNAL MUMPS_275 INTEGER MUMPS_275 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, & LONG, 1, MPI_INTEGER, COMM, IERR ) 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 .LT. LONG * NRHS) THEN INFO( 1 ) = -11 INFO( 2 ) = PLEFTWCB - POSWCB - 1 + LONG * NRHS 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 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_DOUBLE_COMPLEX, COMM, IERR ) DO I = 1, LONG RHS(IWCB(I),K) = RHS(IWCB(I),K) +WCB(PLEFTWCB+I-1) 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 ) PTRY = PLEFTWCB PTRX = PLEFTWCB + NCV * NRHS PLEFTWCB = PLEFTWCB + (NPIV + NCV) * NRHS IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 INFO(2) = -POSWCB + PLEFTWCB -1 GO TO 260 END IF DO K=1, NRHS 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 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_643( & 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 ( NRHS == 1 ) THEN CALL zgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE CALL zgemm( 'N', 'N', NCV, NRHS, NPIV, ALPHA, & A(APOS), NCV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) ENDIF ELSE IF ( NRHS == 1 ) THEN CALL zgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, & WCB( PTRX ), 1, ONE, & WCB( PTRY ), 1 ) ELSE CALL zgemm( 'T', 'N', NCV, NRHS, NPIV, ALPHA, & A(APOS), NPIV, & WCB( PTRX), NPIV, ONE, & WCB( PTRY), NCV ) ENDIF ENDIF IF (KEEP(201).GT.0) THEN CALL ZMUMPS_598(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 PDEST = MUMPS_275( 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 DO I = 1, NCV JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) DO K=1, NRHS RHS(JJ,K)= RHS(JJ,K) + WCB(PTRY+I-1+(K-1)*NCV) ENDDO END DO 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_78( NRHS, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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 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_44( MYID, SLAVEF, COMM ) 270 CONTINUE RETURN END SUBROUTINE ZMUMPS_323 SUBROUTINE ZMUMPS_302( 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, & RHS, LRHS, NRHS, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & MYROOT, & INFO, KEEP,KEEP8, RHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & RHSCOMPFREEPOS, BUILD_POSINRHSCOMP, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & & ) USE ZMUMPS_OOC USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MTYPE INTEGER INODE, LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIWCB, LWCB, LIW, POSWCB, PLEFTWCB, POSIWCB INTEGER(8) :: LA INTEGER N, LPOOL, III, LEAF, NBFIN INTEGER MYROOT INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER LRHS, NRHS COMPLEX(kind=8) WCB( LWCB ), A( LA ) COMPLEX(kind=8) RHS(LRHS, NRHS ), 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(KEEP(28)), LRHSCOMP, RHSCOMPFREEPOS COMPLEX(kind=8) RHSCOMP(LRHSCOMP, NRHS) LOGICAL BUILD_POSINRHSCOMP EXTERNAL zgemv, ztrsv, zgemm, ztrsm, MUMPS_275 INTEGER MUMPS_275 COMPLEX(kind=8) ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0D0,0.0D0), & ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, & IERR, IFR_ini, & IFR, LIELL, JJ, & NELIM, PLEFT, PCB_COURANT, PPIV_COURANT INTEGER IPOSINRHSCOMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG, OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER POSWCB1,POSWCB2 INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, & JFIN, NBJ, NUPDATE_PANEL, & PPIV_PANEL, PCB_PANEL, NBK, TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB INTEGER LDAJ, 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 ) 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_643( & 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_755( & 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 IFR = 0 DO JJ = J1, J3 J = IW( JJ ) IFR = IFR + 1 DO K=1,NRHS RHS_ROOT(IFR+NPIV*(K-1)) = RHS(J,K) END DO END DO 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 DUMMY (1) = 1 CALL ZMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF) 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_690( LDAJ_FIRST_PANEL ) ENDIF PLEFT = PLEFTWCB PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + LIELL * NRHS IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 INFO(2) = PLEFTWCB - POSWCB - 1 GO TO 260 END IF IF (KEEP(201).EQ.1) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV DO K=1, NRHS IFR = PPIV_COURANT + (K-1)*LIELL - 1 DO JJ = J1, J3 J = IW(JJ) IFR = IFR + 1 WCB(IFR) = RHS(J,K) ENDDO IF (NCB.GT.0) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR = IFR + 1 WCB(IFR) = RHS(J,K) RHS (J,K) = ZERO ENDDO ENDIF END DO ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV*NRHS IFR = PPIV_COURANT - 1 OMP_FLAG = NRHS.GT.4 IFR_ini = IFR DO 130 JJ = J1, J3 J = IW(JJ) IFR = IFR_ini + (JJ-J1) + 1 DO K=1, NRHS WCB(IFR+(K-1)*NPIV) = RHS(J,K) END DO 130 CONTINUE IFR = PCB_COURANT - 1 IF (NPIV .LT. LIELL) THEN IFR_ini = IFR DO 140 JJ = J3 + 1, J2 J = IW(JJ) IFR = IFR_ini + (JJ-J3) DO K=1, NRHS WCB(IFR+(K-1)*NCB) = RHS(J,K) RHS(J,K)=ZERO ENDDO 140 CONTINUE 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_667(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_698( & 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+J-1 PCB_PANEL = PPIV_PANEL+NBJ APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN IF ( NRHS == 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 CALL ztrsm( 'L','L','N','U', NBJ, NRHS, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF ENDIF ELSE IF (NRHS == 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 CALL ztrsm('L','L','N','N',NBJ, NRHS, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) 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 ( NRHS == 1 ) THEN CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, & WCB(PPIV_COURANT), 1 ) ELSE CALL ztrsm( 'L','U','T','U', NPIV, NRHS, ONE, & A(APOS), NPIV, WCB(PPIV_COURANT), & NPIV ) ENDIF ELSE IF ( MTYPE .eq. 1 ) THEN IF ( NRHS == 1) THEN CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE CALL ztrsm( 'L','U','T','U', NPIV, NRHS, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV ) ENDIF ELSE IF (NRHS == 1) THEN CALL ztrsv( 'L', 'N', 'N', NPIV, A(APOS), LIELL, & WCB(PPIV_COURANT), 1 ) ELSE CALL ztrsm('L','L','N','N',NPIV, NRHS, ONE, & A(APOS), LIELL, WCB(PPIV_COURANT), & NPIV) 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 ( NRHS == 1 ) THEN CALL zgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), & NPIV, WCB(PPIV_COURANT), 1, ONE, & WCB(PCB_COURANT), 1) ELSE CALL zgemm('T', 'N', NUPDATE, NRHS, NPIV, ALPHA, & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) END IF ELSE IF ( NRHS == 1 ) THEN CALL zgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), & LIELL, WCB(PPIV_COURANT), 1, & ONE, WCB(PCB_COURANT), 1 ) ELSE CALL zgemm('N', 'N', NUPDATE, NRHS, NPIV, ALPHA, & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, & WCB(PCB_COURANT), NCB) END IF END IF END IF END IF IF (BUILD_POSINRHSCOMP) THEN POSINRHSCOMP(STEP(INODE)) = RHSCOMPFREEPOS RHSCOMPFREEPOS = RHSCOMPFREEPOS + NPIV ENDIF IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) IF ( KEEP(50) .eq. 0 ) THEN DO K=1,NRHS IFR = PPIV_COURANT + (K-1)*LD_WCBPIV RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = & WCB(IFR:IFR+NPIV-1) ENDDO ELSE IFR = PPIV_COURANT - 1 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 DO IF(JJ .GT. J3) EXIT IFR = IFR + 1 IF(IW(JJ+LIELL) .GT. 0) THEN DO K=1, NRHS RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR+(K-1)*LD_WCBPIV ) * A( APOS1 ) 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 DO K=1, NRHS POSWCB1 = IFR+(K-1)*LD_WCBPIV POSWCB2 = POSWCB1+1 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = WCB(POSWCB1)*A(APOS1) & + WCB(POSWCB2)*A(APOSOFF) RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A(APOSOFF) & + WCB(POSWCB2)*A(APOS2) 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 IFR = IFR+1 ENDIF ENDDO END IF IF (KEEP(201).GT.0) THEN CALL ZMUMPS_598(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 IF ( MYROOT .EQ. 0 ) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN DUMMY (1) = 1 CALL ZMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF) ENDIF END IF GO TO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN IF (MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), & SLAVEF) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 DO 190 I = 1, NUPDATE DO K=1, NRHS RHS( IW(J3 + I), K ) = RHS( IW(J3 + I), K ) & + WCB(PCB_COURANT + I-1 +(K-1)*LD_WCBCB) ENDDO 190 CONTINUE 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_78( NRHS, INODE, FPERE, NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), & MUMPS_275(PROCNODE_STEPS(STEP(FPERE)), SLAVEF), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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_49( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CALL ZMUMPS_72( NRHS, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_303( .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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) 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*KEEP(35) + & ( Effective_CB_Size + 4 ) * KEEP( 34 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS*KEEP(35) + & ( Effective_CB_Size + 4 ) * KEEP( 34 ) GOTO 260 END IF END DO END IF PLEFTWCB = PLEFTWCB - LIELL*NRHS 270 CONTINUE RETURN 260 CONTINUE CALL ZMUMPS_44( MYID, SLAVEF, COMM ) RETURN END SUBROUTINE ZMUMPS_302 RECURSIVE SUBROUTINE ZMUMPS_303( 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, STEP, PROCNODE_STEPS, & RHS, LRHS & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN INTEGER LIWCB, LWCB, POSWCB, PLEFTWCB, POSIWCB INTEGER LIW INTEGER(8) :: LA INTEGER INFO( 40 ), KEEP( 500) INTEGER(8) KEEP8(150) 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)) INTEGER LRHS COMPLEX(kind=8) RHS(LRHS, NRHS) LOGICAL FLAG INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, STATUS( MPI_STATUS_SIZE ) INTEGER MSGSOU, MSGTAG, MSGLEN 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 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_44( MYID, SLAVEF, COMM ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL ZMUMPS_323( 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, STEP, & PROCNODE_STEPS, & RHS, LRHS & ) END IF END IF RETURN END SUBROUTINE ZMUMPS_303 SUBROUTINE ZMUMPS_249(N, A, LA, IW, LIW, W, LWC, & RHS, LRHS, NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, NA, LNA, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , TO_PROCESS, SIZE_TO_PROCESS & ) USE ZMUMPS_OOC USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MTYPE INTEGER(8) :: LA INTEGER N,LIW,LIWW,LWC,LPOOL,LNA INTEGER SLAVEF,MYLEAF,COMM,MYID INTEGER LPANEL_POS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NA(LNA),NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER PANEL_POS(LPANEL_POS) INTEGER INFO(40) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)),PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LRHS, NRHS COMPLEX(kind=8) A(LA), RHS(LRHS,NRHS), 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(KEEP(28)) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) INTEGER LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) INTEGER MUMPS_275 EXTERNAL MUMPS_275 INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INTEGER POSIWCB,POSWCB,K INTEGER(8) :: APOS, IST INTEGER NPIV INTEGER IPOS,LIELL,NELIM,IFR,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 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 INTEGER DUMMY(1) INTEGER 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 LOGICAL DEJA_SEND( 0:SLAVEF-1 ) INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & PTWCB_PANEL, NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL LOGICAL MUMPS_170 INTEGER MUMPS_330 EXTERNAL zgemv, ztrsv, ztrsm, zgemm, & MUMPS_330, & MUMPS_170 PLEFTW = 1 POSIWCB = LIWW POSWCB = LWC NROOT = 0 NBLEAF = NA(1) NBROOT = NA(2) DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_275(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_275(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_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, & SLAVEF) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0) THEN GOTO 340 ENDIF ENDIF 50 CONTINUE BLOQ = ( ( III .EQ. IIPOOL ) & ) CALL ZMUMPS_41( 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) 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 60 CONTINUE 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 DO JJ = J1, J2 J = IW( JJ ) IFR = IFR + 1 DO K=1,NRHS RHS(J,K) = RHS_ROOT(IFR+NPIV*(K-1)) END DO END DO 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)), & SLAVEF) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CALL ZMUMPS_78( NRHS, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1 ), PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = LONG * KEEP(35) + & ( LONG + 2 ) * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = LONG * KEEP(35) + & ( LONG + 2 ) * 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_170( & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) TYPENODE = MUMPS_330(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 - NCB*NRHS .LT. PLEFTW - 1 ) THEN CALL ZMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - NCB*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = NCB * NRHS - POSWCB - PLEFTW + 1 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 - NCB*NRHS PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = NCB 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 DO JJ = J1, J2 - KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*NCB) = RHS(J,K) ENDDO ENDDO IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1 DO K=1, NRHS IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+(K-1)*NCB) = ALPHA ELSE W(IFR+(K-1)*NCB) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_49( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL ZMUMPS_63(NRHS, INODE, & W(Offset+PTRACB(STEP(INODE))), EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = EffectiveSize * KEEP(35) + & 2 * KEEP(34) GOTO 330 END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL ZMUMPS_151(NRHS,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) IPOS = IPOS + 1 IF (KEEP(201).GT.0) THEN CALL ZMUMPS_643( & 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_690( LIELL ) IF (KEEP(50).NE.1) THEN CALL ZMUMPS_755( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL END IF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. LIELL*NRHS ) THEN CALL ZMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. LIELL*NRHS ) THEN INFO(1) = -11 INFO(2) = LIELL*NRHS - POSWCB GOTO 330 END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN CALL ZMUMPS_95( NRHS, N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 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 - LIELL*NRHS PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = LIELL 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 (KEEP(252).EQ.0) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) DO K=1, NRHS IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-1)*LIELL) = ZERO ENDDO ELSE DO JJ = J1, J2 W(PTWCB+JJ-J1+(K-1)*LIELL) = RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO ENDIF END DO IFR = PTWCB + NPIV - 1 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 DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*LIELL) = RHS(J,K) ENDDO ENDDO IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1 DO K=1, NRHS IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+(K-1)*LIELL) = ALPHA ELSE W(IFR+(K-1)*LIELL) = 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_641(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 + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN CALL ZMUMPS_667(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_698( & 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 ( NRHS == 1 ) THEN IF (NCB_PANEL.NE.0) THEN CALL zgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( NBJ + PTWCB_PANEL ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ENDIF IF (MTYPE.NE.1) THEN CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE CALL ztrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ENDIF ELSE IF (NCB_PANEL.NE.0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & W(NBJ+PTWCB_PANEL),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ENDIF IF (MTYPE.NE.1) THEN CALL ztrsm('L','L','T','U',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) ELSE CALL ztrsm('L','L','T','N',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) 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 (NRHS == 1) THEN CALL zgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(NPIV + PTWCB), 1, & ONE, & W(PTWCB), 1 ) ELSE CALL zgemm('T','N', NPIV, NRHS, NCB, ALPHA, A(IST), LIELL, & W(NPIV+PTWCB), LIELL, ONE, & W(PTWCB), LIELL) 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 ( NRHS == 1 ) THEN CALL zgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( NPIV + PTWCB ), & 1, ONE, & W(PTWCB), 1 ) ELSE CALL zgemm( 'N', 'N', NPIV, NRHS, NCB, ALPHA, & A(IST), NPIV, W(NPIV+PTWCB),LIELL, & ONE, W(PTWCB),LIELL) END IF END IF ENDIF IF ( MTYPE .eq. 1 ) THEN IF ( NRHS == 1 ) THEN CALL ztrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL ztrsm('L','L','T','N', NPIV, NRHS, ONE, A(APOS), & LIELL, W(PTWCB), LIELL) ENDIF ELSE IF ( KEEP(50) .EQ. 0 ) THEN IF ( NRHS == 1 ) THEN CALL ztrsv('U','N','U', NPIV, A(APOS), LIELL, & W(PTWCB), 1) ELSE CALL ztrsm('L','U','N','U', NPIV, NRHS, ONE, A(APOS), & LIELL,W(PTWCB),LIELL) END IF ELSE IF ( NRHS == 1 ) THEN CALL ztrsv('U','N','U', NPIV, A(APOS), NPIV, & W(PTWCB), 1) ELSE CALL ztrsm('L','U','N','U',NPIV, NRHS, ONE, A(APOS), & NPIV, W(PTWCB), LIELL) END IF END IF END IF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF DO 150 I = 1, NPIV JJ = IW(J1 + I - 1) DO K=1, NRHS RHS(JJ, K) = W(PTWCB+I-1+(K-1)*LIELL) ENDDO 150 CONTINUE 160 CONTINUE IF (KEEP(201).GT.0) THEN CALL ZMUMPS_598(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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_275(PROCNODE_STEPS(STEP(IF)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_275(PROCNODE_STEPS(STEP(IF)),SLAVEF) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL ZMUMPS_78( NRHS, IF, 0, 0, LIELL, & LIELL - KEEP(253), & IW( POSINDICES ), & W ( PTRACB(STEP( INODE ))), PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 340 GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 330 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NPIV * KEEP(35) + 2 * 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) 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_151(NRHS,N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF GOTO 50 330 CONTINUE CALL ZMUMPS_242(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, & SLAVEF) 340 CONTINUE CALL ZMUMPS_150( MYID,COMM,BUFR, & LBUFR,LBUFR_BYTES ) RETURN END SUBROUTINE ZMUMPS_249 RECURSIVE SUBROUTINE ZMUMPS_41( & 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, RHS, & LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER LWC COMPLEX(kind=8) W( LWC ) INTEGER POSIWCB, POSWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(40) INTEGER PLEFTW, KEEP( 500) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) 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 LRHS, NRHS COMPLEX(kind=8) RHS(LRHS, NRHS) INTEGER MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER STATUS( MPI_STATUS_SIZE ), IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN 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_44( MYID, SLAVEF, COMM ) ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL ZMUMPS_42( 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) END IF END IF RETURN END SUBROUTINE ZMUMPS_41 RECURSIVE SUBROUTINE ZMUMPS_42( & 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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) USE ZMUMPS_OOC USE ZMUMPS_COMM_BUFFER IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER LWC COMPLEX(kind=8) W( LWC ) INTEGER POSIWCB, POSWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(40) INTEGER PLEFTW, KEEP( 500) INTEGER(8) KEEP8(150) INTEGER PTRICB(KEEP(28)), PTRACB(KEEP(28)), STEP( N ), FILS( N ) 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 LRHS, NRHS COMPLEX(kind=8) RHS(LRHS, NRHS) INTEGER MYLEAFE, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP(KEEP(28)) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER P_UPDATE, P_SOL_MAS, LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER I, JJ, IN, PROCDEST, J1, J2, IFR, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSCOMP 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 DEJA_SEND( 0:SLAVEF-1 ) INTEGER MUMPS_275 EXTERNAL MUMPS_275, ztrsv, ztrsm, zgemv, zgemm INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & PTWCB_PANEL, NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS 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, & LONG, 1, MPI_INTEGER, & COMM, IERR) IF ( POSIWCB - LONG - 2 .LT. 0 & .OR. POSWCB - PLEFTW + 1 .LT. LONG ) THEN CALL ZMUMPS_95(NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ((POSIWCB - LONG - 2 ) .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG + 2 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1 .LT. LONG ) THEN INFO(1) = -11 INFO(2) = LONG + PLEFTW - POSWCB - 1 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=1,NRHS CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_DOUBLE_COMPLEX, COMM, IERR) DO JJ=0, LONG-1 RHS(IWCB(POSIWCB+1+JJ),K) = W(POSWCB+1+JJ) 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_275(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 ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF (KEEP(201).GT.0) THEN CALL ZMUMPS_643( & 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 .LT. PLEFTW - 1 ) THEN CALL ZMUMPS_95(NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS .LT. PLEFTW - 1 ) THEN INFO(1) = -11 INFO(2) = LONG * NRHS- POSWCB WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + NPIV * NRHS PLEFTW = P_SOL_MAS + NROW_L * NRHS DO K=1, NRHS CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-1)*NROW_L),NROW_L, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) ENDDO IF (KEEP(201).EQ.1) THEN IF ( NRHS == 1 ) THEN CALL zgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE CALL zgemm( 'T', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) ENDIF ELSE IF ( NRHS == 1 ) THEN CALL zgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, & W( P_SOL_MAS ), 1, ZERO, & W( P_UPDATE ), 1 ) ELSE CALL zgemm( 'N', 'N', NPIV, NRHS, NROW_L, ALPHA, A(APOS), & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), & NPIV ) END IF ENDIF IF (KEEP(201).GT.0) THEN CALL ZMUMPS_598(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 100 CONTINUE CALL ZMUMPS_63( NRHS, INODE, W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NPIV * KEEP(35) + 2 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS 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 ) 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 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL END IF DO K=1, NRHS CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_DOUBLE_COMPLEX, & COMM, IERR ) IPOSINRHSCOMP = POSINRHSCOMP(STEP(INODE)) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0) THEN CALL ZMUMPS_643( & 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_755( & 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_690(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 .LT. PLEFTW - 1 ) THEN CALL ZMUMPS_95( NRHS, N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS .LT. PLEFTW - 1 ) THEN INFO( 1 ) = -11 INFO( 2 ) = LIELL * NRHS - POSWCB - PLEFTW + 1 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 PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1 IWCB( PTRICB(STEP( INODE )) ) = LIELL 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(STEP(INODE)) IFR = PTRACB(STEP( INODE )) DO K=1, NRHS DO JJ = J1, J2 W(IFR+JJ-J1+(K-1)*LIELL) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO END DO IFR = PTRACB(STEP(INODE))-1+NPIV 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 DO JJ = J1, J2-KEEP(253) J = IW(JJ) IFR = IFR + 1 DO K=1, NRHS W(IFR+(K-1)*LIELL) = RHS(J,K) ENDDO ENDDO 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_641(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_PANEL = PTRACB(STEP(INODE)) + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL ZMUMPS_667(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL ZMUMPS_698( & 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 ( NRHS == 1 ) THEN IF (NCB_PANEL.NE.0) THEN CALL zgemv( 'T', NCB_PANEL, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & W( NBJ + PTWCB_PANEL ), & 1, ONE, & W(PTWCB_PANEL), 1 ) ENDIF CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & W(PTWCB_PANEL), 1) ELSE IF (NCB_PANEL.NE.0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS, NCB_PANEL, ALPHA, & A(APOSDEB + int(NBJ,8)), LDAJ, & W(NBJ+PTWCB_PANEL),LIELL, & ONE, W(PTWCB_PANEL),LIELL) ENDIF CALL ztrsm('L','L','T','U',NBJ, NRHS, ONE, & A(APOSDEB), & LDAJ, W(PTWCB_PANEL), LIELL) 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 == 1 ) THEN CALL zgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & W(PTRACB(STEP(INODE))), 1 ) ELSE CALL zgemm( 'N', 'N', NPIV, NRHS, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, W(PTRACB(STEP(INODE))),LIELL) END IF ENDIF IF ( NRHS == 1 ) THEN CALL ztrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & W(PTRACB(STEP(INODE))),1) ELSE CALL ztrsm( 'L','U', 'N', 'U', NPIV, NRHS, ONE, & A(APOS), LDA, & W(PTRACB(STEP(INODE))),LIELL) END IF 1234 CONTINUE IF (KEEP(201).GT.0) THEN CALL ZMUMPS_598(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 DO I = 1, NPIV JJ = IW( IPOS + I - 1 ) DO K=1,NRHS RHS( JJ, K ) = W( PTRACB(STEP(INODE))+I-1 & + (K-1)*LIELL ) ENDDO END DO 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_242( DUMMY, 1, MPI_INTEGER, MYID, COMM, & FEUILLE, SLAVEF ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL ZMUMPS_151(NRHS, 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_275(PROCNODE_STEPS(STEP(IN)), & SLAVEF) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_275( PROCNODE_STEPS(STEP(IN)), & SLAVEF ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 110 CALL ZMUMPS_78( NRHS, IN, 0, 0, & LIELL, LIELL-KEEP(253), & IW( POSINDICES ) , & W( PTRACB(STEP(INODE))), & PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_41( & .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, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, & RHS, LRHS, NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP & , TO_PROCESS, SIZE_TO_PROCESS & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 110 ELSE IF ( IERR .eq. -2 ) THEN INFO(1) = -17 INFO(2) = LIELL * NRHS * KEEP(35) + & ( LIELL + 2 ) * KEEP(34) GOTO 260 ELSE IF ( IERR .eq. -3 ) THEN INFO(1) = -20 INFO(2) = LIELL * NRHS * KEEP(35) + & ( LIELL + 2 ) * 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_242( DUMMY, 1, MPI_INTEGER, MYID, & COMM, FEUILLE, SLAVEF ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL ZMUMPS_151(NRHS, 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_151(NRHS, 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_44( MYID, SLAVEF, COMM ) 270 CONTINUE RETURN END SUBROUTINE ZMUMPS_42 SUBROUTINE ZMUMPS_641(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_641", & 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_641 SUBROUTINE ZMUMPS_286( 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_290( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL ZMUMPS_768 (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_156( 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_286 SUBROUTINE ZMUMPS_768 (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_768 mumps-4.10.0.dfsg/src/mumps_io.c0000644000175300017530000005154311562233011016666 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #include "mumps_io.h" #include "mumps_io_basic.h" #include "mumps_io_err.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( int *, 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 */ int request_id_loc,flag_loc; #if ! defined(MUMPS_WIN32) struct timeval start_time,end_time; gettimeofday(&start_time,NULL); #endif request_id_loc=(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((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 */ int request_id_loc; #if ! defined(MUMPS_WIN32) struct timeval start_time,end_time; gettimeofday(&start_time,NULL); #endif request_id_loc=(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((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) { 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 # 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{ int inode; 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 */ int io_type; /*read or write*/ int file_type; /* cb or lu or ... */ pthread_cond_t local_cond; int int_local_cond; }; /* Exported global variables */ extern 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 int int_sem_io,int_sem_nb_free_finished_requests,int_sem_nb_free_active_requests,int_sem_stop; extern int with_sem; extern struct request_io *io_queue; extern int first_active,last_active,nb_active; extern int *finished_requests_inode,*finished_requests_id,first_finished_requests, last_finished_requests,nb_finished_requests,smallest_request_id; extern int mumps_owns_mutex; extern int test_request_called_from_mumps; /* Exported functions */ void* mumps_async_thread_function_with_sem (void* arg); int mumps_is_there_finished_request_th(int* flag); int mumps_clean_request_th(int* request_id); int mumps_wait_req_sem_th(int *request_id); int mumps_test_request_th(int* request_id,int *flag); int mumps_wait_request_th(int *request_id); int mumps_low_level_init_ooc_c_th(int* async, int* ierr); int mumps_async_write_th(const int * strat_IO,void * address_block,long long block_size, int * inode,int * request_arg,int * type,long long vaddr,int * ierr); int mumps_async_read_th(const int * strat_IO,void * address_block,long long block_size,int * inode,int * request_arg, int * type,long long vaddr,int * ierr); int mumps_clean_io_data_c_th(int *myid); int mumps_get_sem(void *arg,int *value); int mumps_wait_sem(void *arg,pthread_cond_t *cond); int mumps_post_sem(void *arg,pthread_cond_t *cond); int mumps_clean_finished_queue_th(); #endif /*_WIN32 && WITHOUT_PTHREAD*/ #endif /* MUMPS_IO_THREAD_H */ mumps-4.10.0.dfsg/src/zmumps_comm_buffer.F0000644000175300017530000031074411562233070020706 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). C MODULE ZMUMPS_COMM_BUFFER PRIVATE PUBLIC :: ZMUMPS_61, ZMUMPS_528, & ZMUMPS_53 , ZMUMPS_57 , & ZMUMPS_55, ZMUMPS_59, & ZMUMPS_54,ZMUMPS_58, & ZMUMPS_66, ZMUMPS_78, & ZMUMPS_62, ZMUMPS_68, & ZMUMPS_71, ZMUMPS_70, & ZMUMPS_67, & ZMUMPS_65, ZMUMPS_64, & ZMUMPS_72, & ZMUMPS_648, ZMUMPS_76, & ZMUMPS_73, ZMUMPS_74, & ZMUMPS_63,ZMUMPS_77, & ZMUMPS_60, & ZMUMPS_524, ZMUMPS_469, & ZMUMPS_460, ZMUMPS_502, & ZMUMPS_519 ,ZMUMPS_620 & ,ZMUMPS_617 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 BUF_LMAX_ARRAY DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY CONTAINS SUBROUTINE ZMUMPS_528( MYID ) IMPLICIT NONE INTEGER MYID BUF_MYID = MYID RETURN END SUBROUTINE ZMUMPS_528 SUBROUTINE ZMUMPS_61( 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_61 SUBROUTINE ZMUMPS_53( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL ZMUMPS_2( BUF_CB, SIZE, IERR ) RETURN END SUBROUTINE ZMUMPS_53 SUBROUTINE ZMUMPS_55( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL ZMUMPS_2( BUF_SMALL, SIZE, IERR ) RETURN END SUBROUTINE ZMUMPS_55 SUBROUTINE ZMUMPS_54( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL ZMUMPS_2( BUF_LOAD, SIZE, IERR ) RETURN END SUBROUTINE ZMUMPS_54 SUBROUTINE ZMUMPS_58( IERR ) IMPLICIT NONE INTEGER IERR CALL ZMUMPS_3( BUF_LOAD, IERR ) RETURN END SUBROUTINE ZMUMPS_58 SUBROUTINE ZMUMPS_620() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE ZMUMPS_620 SUBROUTINE ZMUMPS_617(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_617 SUBROUTINE ZMUMPS_57( IERR ) IMPLICIT NONE INTEGER IERR CALL ZMUMPS_3( BUF_CB, IERR ) RETURN END SUBROUTINE ZMUMPS_57 SUBROUTINE ZMUMPS_59( IERR ) IMPLICIT NONE INTEGER IERR CALL ZMUMPS_3( BUF_SMALL, IERR ) RETURN END SUBROUTINE ZMUMPS_59 SUBROUTINE ZMUMPS_2( 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 ZMUMPS_2 SUBROUTINE ZMUMPS_3( 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 on SGI' 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 ZMUMPS_3 SUBROUTINE ZMUMPS_66( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, COMPRESSCB, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT 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_79( 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 NBROWS_PACKET = SIZE_AV_REALS / LCONT 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 ZMUMPS_4( 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 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 ZMUMPS_1( 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_66 SUBROUTINE ZMUMPS_72( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, CB, SOL, & DEST, COMM, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR COMPLEX(kind=8) CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) COMPLEX(kind=8) SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) 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( 4, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_DOUBLE_COMPLEX, COMM, & SIZE2, IERR ) SIZE = SIZE1 + SIZE2 CALL ZMUMPS_4( 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 ) 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 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 ZMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_72 SUBROUTINE ZMUMPS_78( NRHS, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS, NODE1, NODE2, NCB, LONG INTEGER IW( max( 1, LONG ) ) COMPLEX(kind=8) W( max( 1, LDW * NRHS ) ) 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( 2+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS*LONG, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR ) END IF SIZE = SIZE1 + SIZE2 CALL ZMUMPS_4( 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 ) END IF 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 ) DO K=1, NRHS CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR ) END DO END IF CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), IERR ) IF ( SIZE .NE. POSITION ) CALL ZMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_78 SUBROUTINE ZMUMPS_62( I, DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER I INTEGER DEST, TAG, COMM, IERR 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 ZMUMPS_4( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN write(6,*) ' Internal error in ZMUMPS_62', & ' 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 ) CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR ) RETURN END SUBROUTINE ZMUMPS_62 SUBROUTINE ZMUMPS_469(FLAG) LOGICAL FLAG LOGICAL FLAG1, FLAG2, FLAG3 CALL ZMUMPS_468( BUF_SMALL, FLAG1 ) CALL ZMUMPS_468( BUF_CB, FLAG2 ) CALL ZMUMPS_468( BUF_LOAD, FLAG3 ) FLAG = FLAG1 .AND. FLAG2 .AND. FLAG3 RETURN END SUBROUTINE ZMUMPS_469 SUBROUTINE ZMUMPS_468( B, FLAG ) TYPE ( ZMUMPS_COMM_BUFFER_TYPE ) :: B LOGICAL :: FLAG INTEGER SIZE_AVAIL CALL ZMUMPS_79(B, SIZE_AVAIL) FLAG = ( B%HEAD == B%TAIL ) RETURN END SUBROUTINE ZMUMPS_468 SUBROUTINE ZMUMPS_79( 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_79 SUBROUTINE ZMUMPS_4( B, IPOS, IREQ, MSG_SIZE, IERR, & NDEST , PDEST & ) IMPLICIT NONE TYPE ( ZMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER, INTENT(IN) :: MSG_SIZE INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR 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 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 ZMUMPS_4 SUBROUTINE ZMUMPS_1( 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 ZMUMPS_1 SUBROUTINE ZMUMPS_68( & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, & NASS, NSLAVES, LIST_SLAVES, & DEST, NFRONT, COMM, IERR ) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER INODE INTEGER NLIG, NCOL, NASS, NSLAVES INTEGER NBPROCFILS, DEST INTEGER ILIG( NLIG ) INTEGER ICOL( NCOL ) INTEGER LIST_SLAVES( NSLAVES ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER SIZE, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE = ( 6 + NLIG + NCOL + NSLAVES + 1 ) * SIZEofINT IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -2 RETURN END IF CALL ZMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS 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 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 ) THEN WRITE(*,*) 'Error in ZMUMPS_68 :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, MPI_PACKED, & DEST, MAITRE_DESC_BANDE, COMM, & BUF_CB%CONTENT( IREQ ), IERR ) RETURN END SUBROUTINE ZMUMPS_68 SUBROUTINE ZMUMPS_70( 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 ( ( KEEP(48).NE. 0 ).AND.(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_79( 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 ZMUMPS_4( 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 ( ( KEEP(48).NE. 0 ).AND.(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 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 ZMUMPS_1( 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_70 SUBROUTINE ZMUMPS_67(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_617(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_729( 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_79( 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*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 ! defined(DBG_SMB3) 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 #endif CALL ZMUMPS_4( 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 IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 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( 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_47( & 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_47( & 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_67" 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_618( & 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 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 ZMUMPS_1( 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_67 SUBROUTINE ZMUMPS_71( & 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF CALL ZMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST & ) IF (IERR .LT. 0 ) THEN RETURN ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN 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 ) = NCBSON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF (( NSLAVES.GT.0 ) .AND. (KEEP(48).NE.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_71 :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) ENDIF CALL ZMUMPS_79( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE ) THEN IERR = -1 RETURN END IF DO IDEST= 1, NDEST CALL MUMPS_49( & 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 ) .AND. (KEEP(48).NE.0) ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF ( MYID .NE. DEST( IDEST ) ) THEN CALL ZMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST(IDEST) & ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Problem in ZMUMPS_4: IERR<0' CALL MUMPS_ABORT() END IF IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 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 ) = TROW_SIZE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF (( NSLAVES.GT.0 ) .AND. (KEEP(48).NE.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 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_71 SUBROUTINE ZMUMPS_65( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL, & PDEST, NDEST, KEEP50, NB_BLOC_FAC, COMM, IERR ) IMPLICIT NONE INTEGER INODE, NCOL, NPIV, FPERE, NFRONT, NDEST INTEGER IPIV( NPIV ) COMPLEX(kind=8) VAL( NFRONT, * ) INTEGER PDEST( NDEST ) INTEGER KEEP50, NB_BLOC_FAC, COMM, IERR LOGICAL LASTBL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE, & IDEST, IPOSMSG, I INTEGER NPIVSENT INTEGER SSS, SS2 IERR = 0 IF ( LASTBL ) THEN IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF ELSE IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) END IF END IF SIZE2 = 0 IF (NPIV.GT.0) & CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR ) SIZE = SIZE1 + SIZE2 CALL ZMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, IERR, & NDEST , PDEST & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES) THEN SSS = 0 IF ( LASTBL ) THEN IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) END IF ELSE IF ( KEEP50 .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV , & MPI_INTEGER, COMM, SSS, IERR ) END IF END IF IF (NPIV.GT.0) & CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_DOUBLE_COMPLEX, & COMM, SS2, IERR ) SSS = SSS + SS2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF 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 ), SIZE, & POSITION, COMM, IERR ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) IF ( LASTBL .or. KEEP50.ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END IF IF ( LASTBL .AND. KEEP50 .NE. 0 ) THEN CALL MPI_PACK( NDEST, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) IF ( NPIV.GT.0) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NCOL, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) END DO ENDIF DO IDEST = 1, NDEST IF ( KEEP50.eq.0) THEN CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR ) ELSE CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR ) END IF END DO SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL ZMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_65 SUBROUTINE ZMUMPS_64( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU, & NDEST, PDEST, COMM, IERR ) IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE COMPLEX(kind=8) UIP21K( NPIV, NCOLU ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE, & IDEST, IPOSMSG, SSS, SS2 IERR = 0 CALL MPI_PACK_SIZE( 6 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR ) SIZE = SIZE1 + SIZE2 IF (SIZE.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR ) CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_DOUBLE_COMPLEX, & COMM, SS2, IERR ) SSS = SSS+SS2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF CALL ZMUMPS_4( BUF_CB, IPOS, IREQ, SIZE, 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 ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) CALL MPI_PACK( UIP21K, abs(NPIV) * NCOLU, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZE, & POSITION, COMM, IERR ) DO IDEST = 1, NDEST 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 SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZE,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL ZMUMPS_1( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_64 SUBROUTINE ZMUMPS_648( 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_79( 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 CALL ZMUMPS_4( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF 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 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 int mumps_pord( int, int, int *, int *, int * ); #define MUMPS_PORDF \ F_SYMBOL(pordf,PORDF) void MUMPS_CALL MUMPS_PORDF( int *nvtx, int *nedges, int *xadj, int *adjncy, int *nv, int *ncmpa ); int mumps_pord_wnd( int, int, int *, int *, int *, int * ); #define MUMPS_PORDF_WND \ F_SYMBOL(pordf_wnd,PORDF_WND) void MUMPS_CALL MUMPS_PORDF_WND( int *nvtx, int *nedges, int *xadj, int *adjncy, int *nv, int *ncmpa, int *totw ); #endif /*PORD*/ #if defined(scotch) || defined(ptscotch) int esmumps( const int n, const int iwlen, int * const pe, const int pfree, int * const len, int * const iw, int * const nv, int * const elen, int * const last); #define MUMPS_SCOTCH \ F_SYMBOL(scotch,SCOTCH) void MUMPS_CALL MUMPS_SCOTCH( const int * const n, const int * const iwlen, int * const petab, const int * const pfree, int * const lentab, int * const iwtab, int * const nvtab, int * const elentab, int * const lasttab, int * const ncmpa ); #endif /*scotch or ptscotch*/ #if defined(ptscotch) #include "mpi.h" #include #include "ptscotch.h" int mumps_dgraphinit( SCOTCH_Dgraph *, MPI_Fint *, MPI_Fint *); #define MUMPS_DGRAPHINIT \ F_SYMBOL(dgraphinit,DGRAPHINIT) void MUMPS_CALL MUMPS_DGRAPHINIT(SCOTCH_Dgraph *graphptr, MPI_Fint *comm, MPI_Fint *ierr); #endif /*ptscotch*/ #if defined(parmetis) #include "mpi.h" #include "parmetis.h" void mumps_parmetis(int *first, int *vertloctab, int *edgeloctab, int *numflag, int *options, int *order, int *sizes, int *comm); #define MUMPS_PARMETIS \ F_SYMBOL(parmetis,PARMETIS) void MUMPS_CALL MUMPS_PARMETIS(int *first, int *vertloctab, int *edgeloctab, int *numflag, int *options, int *order, int *sizes, int *comm); #endif /*PARMETIS*/ #endif /* MUMPS_ORDERINGS_H */ mumps-4.10.0.dfsg/Make.inc/0000755000175300017530000000000011562233000015516 5ustar hazelscthazelsctmumps-4.10.0.dfsg/Make.inc/Makefile.WIN.MS-Intel.SEQ0000644000175300017530000000676711562233000021650 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # # 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. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 #LSCOTCH = libptscotch.lib libptscotcherr.lib LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ PATHPORD = -LIBPATH:$(LPORDDIR) LPORD = libpord.lib #LMETISDIR = /local/metis/ #PATHMETIS = -LIBPATH:$(PATHMETIS) #IMETIS = # Should be provided if you use parmetis # 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. #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_ -DALLOW_NON_INIT -fpp OPTL = OPTC = -O2 -MD #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded mumps-4.10.0.dfsg/Make.inc/Makefile.gfortran.SEQ0000644000175300017530000000624711562233000021437 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 = gfortran FL = gfortran AR = ar vr #RANLIB = ranlib RANLIB = echo # See point 17 in the FAQ to have more details on the compilation of mpich with gfortran INCSEQ = -I$(topdir)/libseq LIBSEQ = -L$(topdir)/libseq -lmpiseq #LIBBLAS = -L/usr/lib/xmm/ -lf77blas -latlas LIBBLAS = -L/local/BLAS -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -DALLOW_NON_INIT OPTL = -O OPTC = -O #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded mumps-4.10.0.dfsg/Make.inc/Makefile.inc.generic0000644000175300017530000001230411562233000021341 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # ################################################################################ # # 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. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 # 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) -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 = -Llibseq -lmpiseq # DEFINE HERE YOUR BLAS LIBRARY LIBBLAS = -lblas # DEFINE 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-4.10.0.dfsg/Make.inc/Makefile.INTEL.PAR0000644000175300017530000000675011562233000020461 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 = ifort FL = ifort AR = ar vr #RANLIB = ranlib RANLIB = echo SCALAP = /local/SCALAPACK/libscalapack.a /local/BLACS/LIB/blacs_MPI-LINUX-0.a /local/BLACS/LIB/blacsF77init_MPI-LINUX-0.a /local/BLACS/LIB/blacs_MPI-LINUX-0.a INCPAR = -I/usr/local/include # LIBPAR = $(SCALAP) -L/usr/local/lib/ -llamf77mpi -lmpi -llam LIBPAR = $(SCALAP) -L/usr/local/lib/ -llammpio -llamf77mpi -lmpi -llam -lutil -ldl -lpthread #LIBPAR = -lmpi++ -lmpi -ltstdio -ltrillium -largs -lt INCSEQ = -I$(topdir)/libseq LIBSEQ = -L$(topdir)/libseq -lmpiseq #LIBBLAS = -L/usr/lib/xmm/ -lf77blas -latlas LIBBLAS = -L/local/BLAS -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -DALLOW_NON_INIT -nofor_main OPTL = -O -nofor_main OPTC = -O #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = mumps-4.10.0.dfsg/Make.inc/Makefile.SGI.SEQ0000644000175300017530000000621511562233000020232 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 INCSEQ = -I$(topdir)/libseq LIBSEQ = -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 -DALLOW_NON_INIT 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-4.10.0.dfsg/Make.inc/Makefile.ALPHA_true64.SEQ0000644000175300017530000000604211562233000021644 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 INCSEQ = -I$(topdir)/libseq LIBSEQ = -L$(topdir)/libseq -lmpiseq LIBBLAS = -ldxml LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -I. -O -DALPHA_ -nopipeline OPTL = -O OPTC = -O -DMAIN_COMP #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded mumps-4.10.0.dfsg/Make.inc/Makefile.SUN.PAR0000644000175300017530000000622711562233000020252 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 SCALAP = -ls3l -lhpcshm INCPAR = -I/opt/SUNWhpc/include LIBPAR = -L/opt/SUNWhpc/lib -R/opt/SUNWhpc/lib $(SCALAP) -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = -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 -DALLOW_NON_INIT -DSUN_ OPTL = -O OPTC = -O #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = mumps-4.10.0.dfsg/Make.inc/Makefile.SP64.PAR0000644000175300017530000000672511562233000020304 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-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 SCALAP = -lpesslsmp -lblacssmp INCPAR = # -I/usr/lpp/ppe.poe/include LIBPAR = $(SCALAP) # -L/usr/lpp/ppe.poe/lib -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = -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_ -WF,-DALLOW_NON_INIT -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-4.10.0.dfsg/Make.inc/Makefile.INTEL.SEQ0000644000175300017530000000613711562233000020466 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 = ifort FL = ifort AR = ar vr #RANLIB = ranlib RANLIB = echo INCSEQ = -I$(topdir)/libseq LIBSEQ = -L$(topdir)/libseq -lmpiseq #LIBBLAS = -L/usr/lib/xmm/ -lf77blas -latlas LIBBLAS = -L/local/BLAS -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -DALLOW_NON_INIT -nofor_main OPTL = -O -nofor_main OPTC = -O #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded mumps-4.10.0.dfsg/Make.inc/Makefile.ALPHA_linux.SEQ0000644000175300017530000000606511562233000021657 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 = fort FL = fort AR = ar vr RANLIB = echo INCSEQ = -I$(topdir)/libseq LIBSEQ = -L$(topdir)/libseq -lmpiseq LIBBLAS = /home/gil/lib/blas.a LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd__ #Begin Optimized options OPTF = -I. -O -DALPHA_ -nopipeline OPTL = -O OPTC = -O -DMAIN_COMP #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded mumps-4.10.0.dfsg/Make.inc/Makefile.ALPHA_linux.PAR0000644000175300017530000000643511562233000021652 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 = fort FL = fort AR = ar vr RANLIB = echo SCALAP = /home/gil/SCALAPACK/libscalapack.a /home/gil/BLACS/LIB/blacs_MPI-LINUX-0.a /home/gil/BLACS/LIB/blacsCinit_MPI-LINUX-0.a /home/gil/BLACS/LIB/blacs_MPI-LINUX-0.a INCPAR = -I/home/gil/include LIBPAR = $(SCALAP) -L/home/gil/lib -lmpich INCSEQ = -I$(topdir)/libseq LIBSEQ = -L$(topdir)/libseq -lmpiseq LIBBLAS = /home/gil/lib/blas.a LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd__ #Begin Optimized options OPTF = -I. -O -DALPHA_ -nopipeline OPTL = -O OPTC = -O -DMAIN_COMP #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = mumps-4.10.0.dfsg/Make.inc/Makefile.SGI.PAR0000644000175300017530000000636311562233000020230 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 SCALAP = -L/usr/lib64 -lscalapack64 -lmpiblacs64 INCPAR = -I/usr/include/ LIBPAR = $(SCALAP) -L/usr/lib64/ -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = -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 -DALLOW_NON_INIT 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-4.10.0.dfsg/Make.inc/Makefile.ALPHA_true64.PAR0000644000175300017530000000636411562233000021645 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 SCALAP = -L/usr/local/lib -lscalapack_ALPHA -lpblas_ALPHA -lblacsCinit_MPI-ALPHA-0 -lblacsF77init_MPI-ALPHA-0 -lblacs_MPI-ALPHA-0 -lblacsF77init_MPI-ALPHA-0 -lblacs_MPI-ALPHA-0 INCPAR = LIBPAR = $(SCALAP) -lmpi -lelan INCSEQ = -I$(topdir)/libseq LIBSEQ = -L$(topdir)/libseq -lmpiseq LIBBLAS = -ldxml LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -I. -O -DALPHA_ -nopipeline OPTL = -O OPTC = -O -DMAIN_COMP #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = mumps-4.10.0.dfsg/Make.inc/Makefile.SUN.SEQ0000644000175300017530000000605011562233000020252 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 INCSEQ = -I$(topdir)/libseq LIBSEQ = -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 -DALLOW_NON_INIT -DSUN_ OPTL = -O OPTC = -O #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded mumps-4.10.0.dfsg/Make.inc/Makefile.NEC.SEQ0000644000175300017530000000613311562233000020214 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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. # INCSEQ = -I$(topdir)/libseq LIBSEQ = -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 = -DALLOW_NON_INIT OPTL = OPTC = -Kc99 -O -I #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded mumps-4.10.0.dfsg/Make.inc/Makefile.NEC.PAR0000644000175300017530000000631511562233000020210 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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. # #SCALAP = -lscalapack -lblacs -lblacsCinit -lblacsF90init #INCPAR = -I/usr/lib #LIBPAR = $(SCALAP) -L/usr/lib -lmpi -lmpi++ INCSEQ = -I$(topdir)/libseq LIBSEQ = -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 = -DALLOW_NON_INIT OPTL = OPTC = -Kc99 -O -I #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = mumps-4.10.0.dfsg/Make.inc/Makefile.G95.SEQ0000644000175300017530000000623411562233000020155 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 INCSEQ = -I$(topdir)/libseq LIBSEQ = -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 -DMAIN_COMP #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded mumps-4.10.0.dfsg/Make.inc/Makefile.gfortran.PAR0000644000175300017530000000702511562233000021424 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 = gfortran FL = gfortran AR = ar vr #RANLIB = ranlib RANLIB = echo SCALAP = /local/SCALAPACK/libscalapack.a /local/BLACS/LIB/blacs_MPI-LINUX-0.a /local/BLACS/LIB/blacsF77init_MPI-LINUX-0.a /local/BLACS/LIB/blacs_MPI-LINUX-0.a #INCPAR = -I/usr/local/include INCPAR = -I/usr/local/mpich/include # LIBPAR = $(SCALAP) -L/usr/local/lib/ -llammpio -llamf77mpi -lmpi -llam -lutil -ldl -lpthread LIBPAR = $(SCALAP) -L/usr/local/mpich/lib/ -lmpich # See point 17 in the FAQ to have more details on the compilation of mpich with gfortran INCSEQ = -I$(topdir)/libseq LIBSEQ = -L$(topdir)/libseq -lmpiseq #LIBBLAS = -L/usr/lib/xmm/ -lf77blas -latlas LIBBLAS = -L/local/BLAS -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -DALLOW_NON_INIT OPTL = -O OPTC = -O #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = mumps-4.10.0.dfsg/Make.inc/Makefile.SP.SEQ0000644000175300017530000000662611562233000020140 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-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 INCSEQ = -I$(topdir)/libseq LIBSEQ = -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_ -WF,-DALLOW_NON_INIT -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-4.10.0.dfsg/Make.inc/Makefile.inc.generic.SEQ0000644000175300017530000001173511562233000021777 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # ################################################################################ # # 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. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 # 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 = -Llibseq -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-4.10.0.dfsg/Make.inc/Makefile.G95.PAR0000644000175300017530000000666511562233000020157 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #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 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) -L/usr/local/mpich-1.2.7p1/lib -lfmpich -lmpich INCSEQ = -I$(topdir)/libseq LIBSEQ = -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 -DMAIN_COMP #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = mumps-4.10.0.dfsg/Make.inc/Makefile.WIN.MS-G95.SEQ0000644000175300017530000000721111562233000021122 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # # 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. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 #LSCOTCH = libptscotch.lib libptscotcherr.lib LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ PATHPORD = -LIBPATH:$(LPORDDIR) LPORD = libpord.lib #LMETISDIR = /local/metis/ #PATHMETIS = -LIBPATH:$(PATHMETIS) #IMETIS = # Should be provided if you use parmetis # 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. #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 = -L$(topdir)/libseq -lmpiseq LIBSEQ = $(topdir)/libseq/libmpiseq.lib #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 LIBBLAS = mkl_intel_c.lib mkl_intel_thread.lib mkl_core.lib libiomp5md.lib #LIBOTHERS = -lpthread 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-4.10.0.dfsg/Make.inc/Makefile.SP.PAR0000644000175300017530000000700411562233000020121 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-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 SCALAP = -lpessl -lblacs INCPAR = # -I/usr/lpp/ppe.poe/include LIBPAR = $(SCALAP) # -L/usr/lpp/ppe.poe/lib -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = -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_ -WF,-DALLOW_NON_INIT -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-4.10.0.dfsg/Make.inc/Makefile.SP64.SEQ0000644000175300017530000000654111562233000020306 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. If you would like to # use other orderings, 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 5.1 and later) orderings are now available for MUMPS. # #SCOTCHDIR = ${HOME}/scotch_5.1_esmumps #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 = /local/metis/ #IMETIS = # Should be provided if you use parmetis # 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. #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-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 INCSEQ = -I$(topdir)/libseq LIBSEQ = -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_ -WF,-DALLOW_NON_INIT -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-4.10.0.dfsg/libseq/0000755000175300017530000000000011562233007015357 5ustar hazelscthazelsctmumps-4.10.0.dfsg/libseq/elapse.h0000644000175300017530000000520111562233007016777 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #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-4.10.0.dfsg/libseq/Makefile0000644000175300017530000000064411562233007017023 0ustar hazelscthazelsct# # This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 # 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-4.10.0.dfsg/libseq/elapse.c0000644000175300017530000000516711562233007017005 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #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-4.10.0.dfsg/libseq/mpi.h0000644000175300017530000000571711562233007016327 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #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 int MPI_Comm; /* Simple type for MPI communicator */ static MPI_Comm MPI_COMM_WORLD=(MPI_Comm)0; int MPI_Init(int *pargc, char ***pargv); int MPI_Comm_rank(int comm, int *rank); int MPI_Finalize(void); #ifdef __cplusplus } #endif #endif /* MUMPS_MPI_H */ mumps-4.10.0.dfsg/libseq/mpic.c0000644000175300017530000000452211562233007016456 0ustar hazelscthazelsct/* * * This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 * * * This version of MUMPS is provided to you free of charge. It is public * domain, based on public domain software developed during the Esprit IV * European project PARASOL (1996-1999). Since this first public domain * version in 1999, research and developments have been supported by the * following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, * INRIA, and University of Bordeaux. * * The MUMPS team at the moment of releasing this version includes * Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, * Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora * Ucar and Clement Weisbecker. * * We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil * Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, * Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire * Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who * have been contributing to this project. * * Up-to-date copies of the MUMPS package 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. * * * User documentation of any code that uses this software can * include this complete notice. You can acknowledge (using * references [1] and [2]) the contribution of this package * in any scientific publication dependent upon the use of the * package. You shall 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 and A. Guermouche and 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). * */ #include int MPI_Init(int *pargc, char ***pargv) { return 0; } int MPI_Comm_rank( MPI_Comm comm, int *rank) { *rank=0; return 0; } int MPI_Finalize(void) { return 0; } mumps-4.10.0.dfsg/libseq/mpi.f0000644000175300017530000016104311562233007016320 0ustar hazelscthazelsctC C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 C C C This version of MUMPS is provided to you free of charge. It is public C domain, based on public domain software developed during the Esprit IV C European project PARASOL (1996-1999). Since this first public domain C version in 1999, research and developments have been supported by the C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, C INRIA, and University of Bordeaux. C C The MUMPS team at the moment of releasing this version includes C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora C Ucar and Clement Weisbecker. C C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who C have been contributing to this project. C C Up-to-date copies of the MUMPS package can be obtained C from the Web pages: C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS C C C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. C C C User documentation of any code that uses this software can C include this complete notice. You can acknowledge (using C references [1] and [2]) the contribution of this package C in any scientific publication dependent upon the use of the C package. You shall use reasonable endeavours to notify C the authors of the package of this publication. C C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 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 [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and C S. Pralet, Hybrid scheduling for the parallel solution of linear C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 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, ROOT, 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 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_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-4.10.0.dfsg/libseq/mpif.h0000644000175300017530000001044411562233007016466 0ustar hazelscthazelsct! ! This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 ! ! ! This version of MUMPS is provided to you free of charge. It is public ! domain, based on public domain software developed during the Esprit IV ! European project PARASOL (1996-1999). Since this first public domain ! version in 1999, research and developments have been supported by the ! following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, ! INRIA, and University of Bordeaux. ! ! The MUMPS team at the moment of releasing this version includes ! Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, ! Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora ! Ucar and Clement Weisbecker. ! ! We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil ! Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, ! Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire ! Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who ! have been contributing to this project. ! ! Up-to-date copies of the MUMPS package 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. ! ! ! User documentation of any code that uses this software can ! include this complete notice. You can acknowledge (using ! references [1] and [2]) the contribution of this package ! in any scientific publication dependent upon the use of the ! package. You shall 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 and A. Guermouche and 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). ! ! ! 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-4.10.0.dfsg/VERSION0000644000175300017530000000005211562233000015136 0ustar hazelscthazelsctMUMPS 4.10.0 Tue May 10 12:56:32 UTC 2011 mumps-4.10.0.dfsg/MATLAB/0000755000175300017530000000000011562233010015032 5ustar hazelscthazelsctmumps-4.10.0.dfsg/MATLAB/make.inc0000644000175300017530000000330411562233010016442 0ustar hazelscthazelsct# 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/bin/mex -g -largeArrayDims # To generate the Octave interface uncomment the following line # MEX = mkoctfile -g --mex # Main MUMPS_DIR MUMPS_DIR = $(HOME)/MUMPS_4.10.0 # Orderings (see main Makefile.inc file from MUMPS) LMETISDIR = $(HOME)/metis-4.0 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 # We use gfortran LIBFORT = /usr/lib/gcc/x86_64-linux-gnu/4.3/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 # extra options passed via mex command OPTC = -O mumps-4.10.0.dfsg/MATLAB/Makefile0000644000175300017530000000135611562233010016477 0ustar hazelscthazelsct# 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-4.10.0.dfsg/MATLAB/multiplerhs_example.m0000644000175300017530000000105211562233010021271 0ustar hazelscthazelsct%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-4.10.0.dfsg/MATLAB/zmumps.m0000644000175300017530000000416111562233010016545 0ustar hazelscthazelsctfunction [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 = []; return; end if(id.JOB == -1) if(id.INST~=-9999) disp('Allready initialized instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = 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.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; 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] = 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,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; mumps-4.10.0.dfsg/MATLAB/initmumps.m0000644000175300017530000000107511562233010017240 0ustar hazelscthazelsctfunction 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); mumps-4.10.0.dfsg/MATLAB/mumps_help.m0000644000175300017530000001122011562233010017355 0ustar hazelscthazelsct%**************************************** %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. % %--------------- Internal Parameters --------------- % % - id.INST: (MUMPS reserved component) MUMPS internal parameter. % % - id.TYPE: (MUMPS reserved component) defines the arithmetic (complex or double precision). % mumps-4.10.0.dfsg/MATLAB/mumpsmex.c0000644000175300017530000005170411562233010017060 0ustar hazelscthazelsct#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 (prhs[2]) #define CNTL (prhs[3]) #define PERM_IN (prhs[4]) #define COLSCA (prhs[5]) #define ROWSCA (prhs[6]) #define RHS (prhs[7]) #define VAR_SCHUR (prhs[8]) #define INST (prhs[9]) #define REDRHS_IN (prhs[10]) #define A_IN (prhs[11]) #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 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); \ MYFREE(mumpspointer); \ if(ptr_matlab[0] != -9999){ \ 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 ); 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_double; 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 inst,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 doanal = 0; EXTRACT_FROM_MATLAB_TOVAL(JOB,job); dosolve = (job == 3 || job == 5 || job == 6); doanal = (job == 1 || job == 4 || 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); 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(doanal){ /* || 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 doanal */ 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,dmumps_par->icntl,int,40); EXTRACT_FROM_MATLAB_TOARR(CNTL,dmumps_par->cntl,double,15); EXTRACT_FROM_MATLAB_TOPTR(PERM_IN,(dmumps_par->perm_in),int,((int)n)); EXTRACT_FROM_MATLAB_TOPTR(COLSCA,(dmumps_par->colsca),double,((int)n)); EXTRACT_FROM_MATLAB_TOPTR(ROWSCA,(dmumps_par->rowsca),double,((int)n)); 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); /* * 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 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 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 */ /*JY: 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,(dmumps_par->rhs),double,1); }else{ nbrhs = mxGetN(RHS); ldrhs = mxGetM(RHS); dmumps_par->nrhs = (int)nbrhs; dmumps_par->lrhs = (int)ldrhs; if(ldrhs != n){ mexErrMsgTxt ("Incompatible number of rows in RHS"); } if (!mxIsSparse(RHS)){ /* full rhs */ dmumps_par->icntl[19] = 0; EXTRACT_CMPLX_FROM_MATLAB_TOPTR(RHS,(dmumps_par->rhs),double,(int)( dmumps_par->nrhs*ldrhs)); }else{ /* sparse rhs */ /* printf("sparse RHS ldrhs = %d nrhs = %d\n",ldrhs,nbrhs); */ dmumps_par->icntl[19] = 1; irhs_ptr = mxGetJc(RHS); irhs_sparse = mxGetIr(RHS); rhs_sparse = mxGetPr(RHS); #if MUMPS_ARITH == MUMPS_ARITH_z im_rhs_sparse = mxGetPi(RHS); #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){ 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); 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); if(dmumps_par->size_schur > 0){ 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-4.10.0.dfsg/MATLAB/zsimple_example.m0000644000175300017530000000327211562233010020412 0ustar hazelscthazelsct% 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 rigth 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) disp('Press any key'); pause; % 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); % JOB = 6 means analysis+facto+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 = 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-4.10.0.dfsg/MATLAB/README0000644000175300017530000001012311562233010015707 0ustar hazelscthazelsctREADME ************************************************************************ * This MATLAB interface to MUMPS is provided to you free of charge. * * It is part of the MUMPS package (see ../Conditions_of_use) and is * * 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 info is available in the main MUMPS users' guide 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 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 find 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 schurrhs_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+facto+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-4.10.0.dfsg/MATLAB/simple_example.m0000644000175300017530000000214111562233010020212 0ustar hazelscthazelsct% 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-4.10.0.dfsg/MATLAB/printmumpsstat.m0000644000175300017530000000256111562233010020326 0ustar hazelscthazelsctfunction 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-4.10.0.dfsg/MATLAB/sparserhs_example.m0000644000175300017530000000112311562233010020732 0ustar hazelscthazelsct%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-4.10.0.dfsg/MATLAB/dmumps.m0000644000175300017530000000416111562233010016517 0ustar hazelscthazelsctfunction [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 = []; return; end if(id.JOB == -1) if(id.INST~=-9999) disp('Allready initialized instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = 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.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; 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] = 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,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; mumps-4.10.0.dfsg/MATLAB/schur_example.m0000644000175300017530000000421411562233010020050 0ustar hazelscthazelsct%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-4.10.0.dfsg/MATLAB/lhr01.mat0000644000175300017530000074250011562233010016473 0ustar hazelscthazelsctMATLAB 5.0 MAT-file, Platform: SOL2, Created on: Thu Oct 4 19:03:15 2001 MIĸProblem titleAZerosbnameHLight hydrocarbon recovery. OK if illconditioned,from a nonlinear solvr yH">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~gmnhmnimnjmnkmnlmnmnYmqnnonprstuvwxyz{|}~q     -/0123456789: ; < = > ?@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@UVAUVBUVCUVDUVEUVFUVGUVHUVIUVJUVKUVLUVMUVNUVOUVPUVUV=UVVVX     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^bdhltvyQWX\^`bdfhjlnprtvxz{|~RWX\^`bdfhjlnprtvxz|}~SWX\^`bdfhjlnprtvxz|~TWX\^`bdfhjlnprtvxz|~WX\^`bdfhjlnprtvxz|~AW]_acegikmoqsuwy{}"XY\^`bdfhjlnprtvxz|~#XZ\^`bdfhjlnprtvxz|~X[  $%BUVCUVDUVEUVFUVGUVHUVIUVJUVKUVLUVMUVNUVOUVPUVQUVRUVSUVTUVUVAUVVV[-@Ap.@Aq/@Ar0@As1@At2@Au3@Av4@Aw5@Ax6@Ay7@Az8@A{9@A|:@A};@A~<@A=@A>@A?@A@A,@o2A3AAF   "$&(*-   "$&(*.    "$&(*/    "$&(*0    "$&(*1   "$&(*2   "$&(*3   "$&(*4   "$&(*5   "$&(*6   "$&(*7   "$&(*8   "$&(*9   "$&(*:   !"$&(*;   "#$&(*<   "$%&(*=   "$&'(*>   "$&()*?   "$&(*+   !#%')+,F-GHIKMOQSUWY[]_acegikm.GIJKMOQSUWY[]_acegikm/GIKLMOQSUWY[]_acegikm0GIKMNOQSUWY[]_acegikm1GIKMOPQSUWY[]_acegikm2GIKMOQRSUWY[]_acegikm3GIKMOQSTUWY[]_acegikm4GIKMOQSUVWY[]_acegikm5GIKMOQSUWXY[]_acegikm6GIKMOQSUWYZ[]_acegikm7GIKMOQSUWY[\]_acegikm8GIKMOQSUWY[]^_acegikm9GIKMOQSUWY[]_`acegikm:GIKMOQSUWY[]_abcegikm;GIKMOQSUWY[]_acdegikm<GIKMOQSUWY[]_acefgikm=GIKMOQSUWY[]_aceghikm>GIKMOQSUWY[]_acegijkm?GIKMOQSUWY[]_acegiklmGIKMOQSUWY[]_acegikmn,HJLNPRTVXZ\^`bdfhjln0DGIKMOQSUWY[]_acegikm1EGIKMOQSUWY[]_acegikmF-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[]_acegiklmBCGIKMOQSUWY[]_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 pqrstuvwxyz{|}~opqrstuvwxyz{|}~o45 Nabfghjlnprtvxz|~Oabfhijlnprtvxz|~Pabfhjklnprtvxz|~Qabfhjlmnprtvxz|~Rabfhjlnoprtvxz|~Sabfhjlnpqrtvxz|~Tabfhjlnprstvxz|~Uabfhjlnprtuvxz|~Vabfhjlnprtvwxz|~Wabfhjlnprtvxyz|~Xabfhjlnprtvxz{|~Yabfhjlnprtvxz|}~Zabfhjlnprtvxz|~[abfhjlnprtvxz|~\abfhjlnprtvxz|~]abfhjlnprtvxz|~^abfhjlnprtvxz|~_abfhjlnprtvxz|~`abfhjlnprtvxz|~bpMagikmoqsuwy{}*bcfhjlnprtvxz|~+bdfhjlnprtvxz|~bep9:,D^_`abcdefghijklmnopqrstuvwxyz{|}~ !"#$%&'()*+,-./0123456789:;<=>?@[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ $%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLefghijklmnopqrstuvwxyz{|}~      !"#$%&'()*+FGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmn  !"#$%&'()*+,-./012345;aLMNOPQRSTUVWXYZ[\]^_`a~<  $(,048<@DHLOQSVX\`dhlptx|  !%)-159=AEIMQUWZ]`cfilorux{~ ";Tm)B[t8Qj2Kd}  !%)-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 #<Un2Kd},E^w #'+/37;?CEHIKNg/Haz)@WY[^w &?Xq 9Pg~.G`y(AZs &?Xq 9Rk #'+/1457:Sl4Mf,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:0Q0h0k0000011131L1e1~1111122-2F2]2t2v2x2{2222233*3C3\3u33333344,4E4\4s44444455!5:5S5l5555556616J6c6|6666666677)7B7[7t7777778 8&8?8X8q888888899+9D9]9v99999::!:::S:l::::::::;;;7;P;i;;;;;;<<1>>5>N>g>>>>>>?????2?K?d?}?????@@,@E@^@w@@@@@A A"A9APASAjAAAAAABB0BIBbB{BBBBBCC*CACXCZC\C_CwCCCCCDDD7DODgDDDDDDEE'E+EAEXEoEqErEtEuEvExEzE|E~EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEFFFFF F F FFFFFFFFFF F"F$F&F(F*F,F.F0F2F4F6F8F:F<F>F@FBFDFFFGFIFKFMFOFQFSFUFWFYF[F]F_FaFcFeFgFiFkFmFoFpFrFtFvFxFzF|F~FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFGGGGG G G GGGGGGGGGG G"G$G&G(G*G,G.G0G2G4G6G8G:G<G=G?GAGCGEGGGIGKGMGOGQGSGUGWGYG[G]G_GaGcGeGfGhGjGlGnGpGrGtGvGxGzG|G~GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG ?ؿ?U'??es??z@?j?RNV%??f?bܱ;~?? `Y?\s??C?_-ؿ??ZY?f Vߚ}??6{?dCw=`??(?gBWOcۿ??6H?ez? ??j?? b?gOvkο?? b?l(')J??ʼn1?X@;Sӿ?? b?o6?? b?ptie?? b?kXп?? b?kuK??ʼn1?m<5%?? b?mɸz? b?m?ޕf?N?.ʝ?ߴTx?D8?eAkMI~??c\u{=1V?|u?f< l2 ?‘"?k5)?v?rP`taf3%?y?xsaP??xEv2خɿ▋?Ж?|,5E ?Ⱦ^?| ?̛G?3?)??,/F՛?]v?ϼ7?͵??l7?E?N+A?љ֤?VʡpQm?ӓ? q̙ ?)ʞ?Zm`՛?\?~a:?V?`?WU?#x#?a Eڿ_ؿ??D8d??w.??|ukƊ)??‘"`&T??v俖8jA??yؿOw ??)IzĹ??Ж).͎j??Ⱦ^߿vĽ$??̛Go1??RkՅ??]v"??͵ƌ;??E"T5???љ֤> (F??ӓ8؏??)ʞH??\$Jx??V uqS?WU`| z?#?dP?{UbXr?s@p??D8?@)ȁ}??C3??|u?(t][??‘"Nw ̕t??vk`C2??yؿ܃7ܿ??@\h??Ж Zv4{??Ⱦ^߿:2??̛G Y2*??㿴 ym4??]v CY??͵ ڡ??EpDr??љ֤ȀcK??ӓpdM??)ʞk??\$3Yg~??VWە@l?WUkW?#?@"ݯ탿ALW@??"J|Po?zEbz??D8??t??|u??‘"??v??yؿH??o??Ж??Ⱦ^߿??̛G*(??щ'i;bƾ.d=TPwt edyk=~pdt<)(:N%= $hkp#JW i]T885J[¾3CQsJƄfP?9DzR?E~Ͽ p 0m>y[?=*v<>kb>d>g5&$>(O2>zVY>q>*W>O!Sj>{T=sSS=*{d=ݏeo>XyGb >T>6~^>4P,n>GAC~?9hpR? >qϾ6J>x2?UJ`$Ӿr*98fMM$?9ClQd>b06t!KMD6U7xx+q&>U+oՏ'/IlK`{ݾyMvpz?9䴛ŒEm? ,ĒH>Ax|[ږ.>e3Bó?`A!V1>΀>ByF>j?OH^>il>~X#>6z>[~>&]۸=H=_d=u(L=*>ejt >bq>Cnt>A>!!?9䩺Ϳ$f?;GP>a tľiu>Ƽ>jth?K1Y>IRê>!>>t!>FV|>jӍ.dߐ>$[>Qo3e=vy-G= S>t_E>qǓ >R/V\>Q~>1UqĿ?9>oQ~?RCn->]>q_>,ɣ\g?]lfk>)ے>Zq>O +{>r6qU>,3>&^(=Fu=Ÿf>} _>xJuue>ZZ\Q ;>W>` >7v<?9Y:I狚h?D!>ӧ׊{H>kk>(Z|>C7eβ>f?Q%(Ab>O^>8"i>PtX:G>sG)U!s>.S, T> vd&m=}'=ïFm">~w>ytr>[(IX>Y+@獸 >92Ŀ?9IU?k;JJ\C>v>{r{1>||>T>[>?aHk˄>MD>T;X>y/ e/f>3OF>BpK=@_%=X =>PF)>>a.K>`C1 >?MдK?9x9'%? Kـ(>r'p?> >Nxo>);Ea>;b>C֠+>N6(?cCH#">U v/>zmE>4D4t\>3ؙ=CkY=Wj>X\>Yh|>bnNW>`bڬ >@ɷן0?:M~ǿgbFo?U0TJ]ƍ>輿BB?r>V>}n >&Co>nю>]g>`]=e?Zz<>z/%>>hm8 >h=X=ܥe>>*q C>l&$>i\ɉ>IR5qq?:OgZyg?Bh׿Qn'M>9S1sF?9^>J>*`>so>\>\D1>[Ů8->}?z:ǘ f>9>Y02=S|+=ХqZ>Q>3>g>eA? >E8X8?L t{ ?z5W뚙?Zbt+ mă k? mm[2>WTYW>daݧ>w>4e6>mE >c7QR]> {HjJ>A5?x5u>=go6T{=B->i{o>ir>pJR>mh&>>M&1`?rrt=?JXTUsu>352"3?s>X>:&[>s:>Zē>p >fR^d>cgH<`>;P>@Ne>0$?x7=ZC=f t>y@>:>m@|3H>n:?>LF` ?DGb3?N?.5s?Q[>.>.l>Œ5Z3>9#>]jky>Z]>[)>D9&p>@=E??x+ִ=B>(f7>[f>hEZpx>tG)>A/aF?35?܃0]?e iu? e챣ZJe (~r2GiZUa?wUU侤~Ge tjSQ?:řݿݒv7?3P)>c)R7Fy ?ZX >O>W3}>IEП>;'>|M>Zup-E>}lP>8ak,L>i:[5=c,b=ϳn->Gr?{#2I>GV>fgZc>d;a;>D2O.:?:Ebf_i]ai+?YLP.>CVjGlZ?Gn8>#i'>I6;>Q>#h±q{>kj>Z\e;6>p䶜>8Kϳp>uӬ#=a殯=ϗ x,>BUfc>*ORx?z˳*>fRrF>d('p>D K}J?:07/ʻ?⨋S\d?> ̼fW!? >ojo>Ӭ>,I>uOE>xg>_v>fʦ>=X_>N~=u=Fv/>V>#t>jq%4?yTh4>h]-Ꜧ>HQ׉3?;{6t@?4SBVf>5,Nf0Z+H?>G ۛ>ӄ >,q>Qt>s¯z>_v s>|@@>=%,q>ݵL<=fb=e>'8v>)R6>j嚴3B>h7Wv?yEg>H!?8 v?W\RWOkf?%ǧ ??k8>fճ>'[!T>e 4>R>ݓ>b>,6U>AAi>=Ov=0s==ք>{S>ot>oj>l)g9A>LB?xmE9ج{?Y%?Y2οR 8ZϿ@}DтTqΞ#QfQM .f+ x;|xX}ǥUcXS";0ћ??Ňq!?V/"?<92?4E{|?nH?T78a?IY1G?ryuT>I*>c-M>pqԠy>L"~=KN? w~ ?xw >e/G#>>n>c̥<3%@3ST༮o=ֲo5a>grgK]Q89.; ϿXZ ο zFAR.pI|x~Kc2>/п|ۅX!>raNDD>6E'>|_u>'DL>^8b|>~-\|>1^ֺR> W=˟tx!4p>5d4>>[_1 >fGp >'WeP?:9? ͉L$?Xw O\ k-?R a>?,4>&('5n:C:&RįqI=S_O=ϡOj=ʔ =O(cC}`bVq=Q5Ɨ2l5J>HN+?_?mv}1K󡿝+07??lpmnզe (CBz[҄ɾ:Px>'>;|.x>o3>RIl>r>'j>\1 =RM&A=`$l>uYϘ>vCa>R>\wB >"fB?Ѯ?Q8B k2m`}MZ >^y)YRlӥnľYBS> 0Twc~rL>I̡>{k#4>}ђ>72Aee>Vpg})>Ǻ=vé=Ȣ!wJ=t>[f;>cVxk>;4>Azצ>QE??>^M݀gLH4X9Vm$kԿQp2q4Zjz՞1>/ytϾ-rf>*\Ea>,e QΘ= =1)=sC=CB>6|>"Ƈb> $d>Vp> ??UQmBLdH>EYfRs8G4} ⾅g쾏3 2b$*EF#&E>KR>cb\>eva>mgΆQ>=?o=F'=р 8=sd=vma >@),)>I~e5>:lW5>&!uQ=a:?z?&-?yכYfs?L9:=>i O>4ϓ˾Y.lw Qr{8ܬ+)ؾJ>ʽ%z͚T_d,=GfF=@K=F_7];F!!q_](3޹n=˨O%D?I?@˺,Kh"?wծ+|Ѿ+?K?GKQr:>3" 6}|Rƾu᧔q ؾx4\u,豾LvKF$ڿ|Z罘 ł=TS5FH'O+]E\7/9 )= 25a/?w?ISm߮/?X?΋ Jv?W(>*(nYr>Ÿ߾㑇ZxcodQ߾8Ѿ?>ѾY(,6Ǿ ᇁjEhŽ_lH =s31|E[IKhҾξ5*詾Beer7H+O$?? a}]s.8?ƹ`"U@>tB?&ݜmZBvd nˠA(<бYzooa=*`ZʾU:^9U%I!]:Ծdцn+0:Bv@SAJ&p 3?mg?hv>>RK2>e)]C:S}Ⱦ8<Wv90[NMT3vd*l/0 [銤eeeV.?ʾ9&10#sA/}I_dYJ?gq?,;x8Q?EfX>.7?V΁9?tE>@cqx>8˾mB:Sqk>FZ6Zپ]K޾7 s<!RbRZ'Fg_]CXbF1\Z[9??<5?f9W>TNl?YTγ? ~ >}\I\)>K}|p-EǾ:TSB TȾaNLK:'y2vоU荽lF,HJ7+eq?AWk:T@;G:sJR#U?(?fYt5?h X?!:?FH?d ,3>XQ>UL>R!jd|a]о8XXzVSjRBZ2MYkqbi_")-׾XD#cA:t(k'χ_? #??רӿ<1o?cxPr?0s59H?t& >‹+A>X>L>F}>[~3PDGSUf-Vš*g-qoOE{[fqdHB߰Dj;*`/*Ó?i?ͽӜR?wk0s2oA3?LJY9#@>l}[>ŞCA><ǾxҷϾu\QGwtWE1.*bľPӷ†Р|#Ë!G?c*ʗǝS㦟*U;_]y}2+g9I3˰Ⱦ e8қ??[?,wu`?Z>o?\:qZ?Mx'Y>.ye>K^iQvkF+TcE/;$E>gc۵T^ H۰b6eؽﶛꉦ}gz#> aapzmLRU7v׾=cFIG?iUP/s ?xY?sx?T v?yE4Y> siM?O׊>q̷=a>\UM3>jK hpxоv'iվx75: ɾT{90 AN`/> Š 9־YD`HK"9Q5w?ʡ@?iI ~OM ʿ?I?zv*h?:l<5F?[{LL?آ~%>,Sq >(qwz 4)j3\@Ni)m`*Zp^=x~SbfپlDQAGgHdKt6ő$ay???l8hk?eӥ}?E$e@>/!ҫ>dI6QD~>߭ZN>_eweiA8h@p2oXϔʾQ 5ؾtͽ2UL$A6'畾VW}VRfh'c;{nZ:vAthv ď?n?e"C?0J?X7>?@*?SY/hg?%]? K$>ꤣ>x|zb>Xۿd>tw fh>?^>H6>Ao@p=j=cD>p,>ϐ,>G6l>]>W'R ?X#L??hsl?i?f???ཿ*?? `cR??mv=ڿ??Q8V??>^SWM??֟!t+??&-ؼiOi!??@˺܅"??ISmlD?? a} ??~??,;?-ǿ??qٜ69??f:M???ܜf??ͽ??,wCp??sM ??rbV?fC?C?\?fBg??36*?Ā೿0???ཿ?? ݣ??mvY??Q8??>^ ??J??&-??@˺_??ISm?? a}/L?????,; ^??h??f!,???(d??ͽ??,w??s???o??CZ?w?4x?7+#u?⹻?c/*?itGoF&?]P:ƿP"2=w@HSPEVG}QכҾ)/<~Y Wd'3+uK[l Zgke b¾s)?`˜ež 1?fz >?E@Ol?,7^YZAqA?M<?0U$7{?3ld?@>դ8T>`&7>Zi/>Đ!zZR>{w>U#a >1E{#> 'pf>RL W>nߗ`>}v<>i>n8:?!߿̊??}y>>)A>,K">b>>>jLqY>.v>ܽ^4z,>)G,>3\=>0ol>?2ſ?dZq?C~'?bwzbO?j|:?M=Ia*%?Q_GI?6;?*?uys?i>zFE>"Ъ08>:ZuD>r]>Nw1>(K>5̛>2Fqu+>>~k>dT>Hjw%?{{imX]?{{A|?j0ۿ5?r^b?U|??|Hoˊ?⸇?2Tn)5G?Sdh?wX6>Z<>z>C"`>zlFs`>>Us>1K>fp>$N$>.C&Lc>w08>3U?Yc ?YcT?lN迿ӻu?sg?VH؟!?@0?3'?.#-;?S ??8C>Psk>.H>= k$>{`XQp>VԪr>2D-l>!D>!!>+?`>]:!>f7l?QXVՇ~>cE>aZ>(2>]6*>76u>nEz>2*>?,Ź>d9>s?OrHڋ{?OrH͌2>B8I> j'>m>^F-T>8܃>o!>[\n>iMXH>_>ki8&?vQIa?vQ^7{"?|e7|M?-Bt?fZ.?P}0z?DiC_빉?)+? pPq(?>YNU? >Bl%>EPSX>~b>gI,Y>Bנ?gFXS?}rV>⌨L>஛<0&>o[|?xqn/+?xqһXe:1?w-?4B?bK?L]:5?A/Z!?%-Kp?tj">Je>' ZrW?m/Zp>+>PI.>csX;>?B]>?b7솬>䵿>5O>>7(?<$8Zz?<$˨?l;'R,??j4?S^}?H 2}8?-v䋺?#Hy>pj+8?Fa~>_!= ?t#>v4>kOi>EH# ? Rw?{I2>e>˙Y>32:n?=?6im ? ??p (z ?WP1=Z?N UW>?3+.k?'P1 2>ߚ7Y ?_[KE> >4nǼm?Rz3۽>pkl>G?k4?Yq˫%c>~to>>>9?rE?rES&?Ӆyl"?ı_?t?`W:^l7?WIJ6?:H?1?6Hf;>HAJ?OМ/x>‘Q>H>qt'>{{m/?/f.>L9R?@ ~? H;>q*>>W:_c)W38?ӳѳg?ӳI ?ӳĤ?rӳ"0?rӳ?W.?G?.*S?.A3>ޘ>F">.*Q>=ۥ^?jwi?9K?"ӳ$?ӳ?y=]sD"?>ଃ?:7?v$N\ڿmM/6?S?b_uh?J5UW%?@6/?$:k? v>L> Fnd>[vXw>:>b]:"8>>]?~M}?浪ɨ>eGlY>yO>ډS:(!>G뼄M?D(?D?v +% ?Y?b"R?JpA>?@+?#nS?Q[>jQ>O>{>'5>bu?L >=/*?rx>R%?ags>c)>ve\_>S?#^tb=~?Ձk?{uoX?br?eԵN?PQbX?Cs?(-?tPP>Ԅ~>Mf>/#>ZL>f`|W>B*J*?*RZ?'>ѽY2~?j>^>hɿ?{zѣK\s?{zѣT|?{KvK!?Bgh?e o?P9Y/?C{+Ds?(,?gó>dn۹>EBM>r2e?>5՟:>f: ;=>B M$1K/? ]nX?CW>m >G"?R>ё#?y>c Iq?~ 9ħ?a0c?iFa?S ӁJ?G{OG|-?,g>?"M%>KW>šMV>t9>>j@ȓ>EMmrH?0Z?v1I>%e>⟦Ob>_" ?*F{?`?$DLjl / tHTs5p Fbz%ٖ\O% xƔe?MiIf~dobr=hhL1̾+`4Ⱦ߉h0,sQhRܿ?|Cl?w;?\i%?_F:?2?tI՝yZ1?Y4+n[?Nܟ?1)vl)?&B>һu ?j:1>0>m-~>i/!?>C٘? XU? @>93>Io>.oSkZڙQA aTQR{=}kL_H5,sorabUhMxesOilI;bT@/Eusݾ,L@Cie[)? K;,|UpP(?EJJ5y%ؔd7:?H׸??'WybCNmW{:?2 X\](ܟ4V4/^FY0><3>2`>iT!>U^]Pc>v%>#2=jխȽoc >v->/l>Nډ >`ZT=I܍?~ ?͡?hp1r /[x&z X?\0[>߅.&@>,q",[Ԏw۾}uI)e«0@A&g58=7N\}=uFA=V=s'vzL %AI4`A֜P> 'Eb>m<??˹tn~RFĄ?#z$ο+.\u6 -=%6ξ&
    ]>Ŵ`>Ƅ>Kmɖ>l]/>h=x3l=a:>ll"o>~4hy>E1an>Uxc>!Mҭ??RI])鿆Hg`>KIQ] 鰿tZ&8f>VC3 >8>uW &>{Iۼd>2=|cf>ROL>9ݒ4=fqJIU=tmp=֍K>T!>`NxR7>3Dh3?>;_L>O???VzWOlQ=6E{jN/󻠘'Ǿ{#VORV$yr'WAx(uň>34 :>1g=oIb>%>2L;c^=%#}2=Q1=>^=c/7>:_">2eWP>!..#>_-7@>!<?? 0`02u;%q?>wZyK51F?^c&'lQV#J7A>R(clL>e㫦>kmu=>?>A>@M@4>O=S>xj>'.!Yz=V7z??=j?~6ͻ RiF?Q`R>VtTzg>;־#:ҿ1&WYpK[ەt˖^Yfb=t$ƢYfJg=d =tX׾6v@SmYL 3%Mp=Of<? ?1/ R?y/oǸ6 ?N>^=>6?Da>IV> "I-SjYL!E*'pFQvA>Cnr R|/Lqc='=u![I=V^QbJpu*0}&Ώ/=vu?Y?<߱x?R!D6b?^o?K}>4˶>0Zæxn-ܾzo𤦩#M;Iw=-#[U*OybMXϽp D=1R\=Oo1MHZaV"'/64ӛ=f?QT?^^ݖ? s+[?a lT? ςal>(&> ؇02ޛ{$' aq5; 󾻄SUt : tG5"4M?{}>h͑W[KGݾd?ۢj4b@w+4*Ȱ(??r^?Q/]sH?Wƿ>?"7>*>'6};m܋r! w_hRPƧ+UpK걜e;9@eR6zC;qz7>N3"c[?̛*zu4jMս??`hZ?$^>,h?Wyn5H? ">21>q^V-nRپnfzrt 1~Ql"( *@n\SXRDB} vVY!`:zUy;[B v%̀7&/ d :7qUR.67?0? 6?=&ǟ??Zx$À? \ A1>ﴲD$5>%Tf,4=E}pV s,BFL534TJ5(;,R"f۲w6^Ǚx>V 2lZxs[^< 7ꉾ?vK3Zse؈??ſY[boO[xO?tY5?!$ UR>d03+|>3g>[,L>d&࿐(׋2paEg3^о5lJp2nѺp;(S3DA'$K<՚h1r^(!t;z??\,:Sx~'R ?%~kĻETřv?~xi?>4:J>s;I{ >8P>sB2 >{ ߨR!q OE9d@ޜ*64 AȽN"ؽ~4z7(nbQUR \i>GWٺm?D߾&U+9& IN?&?5BJ?ur@b3?LP'Zn>L>.V9J>ڍV-ue>,'njaYY(X"/T}B4EİDIX˛Bk {~fDd{lӾP]i޾#LE+(;Ug8mX't?r?j CQJ?23_l y?azt?̩->2Cp>|$^^) ,}F_ݾߢw2jcS^aȧ|35S?NC 1>D>`>OcRc(hoF{8&FlxFUӽ۽DKjyQ[ؾ-C-rGGf1,V 9!KR??_ƿ9?%L$.t?`?g4>.-y>D9QC]yzX{(XH~380*SׅSľ,'۽Ofj|CriUwB޾c.72A]w=Lɾ@q.M0t1?0,K[?CI1S?w5pTM?4=xu>}m;6I>m @>L6͵>ב56>#y=Zo>;v3i"=ӏ@]u]iluPʽ 7炽7I! vI?8`AYGa1S%~)֮ĝٟ6辮v2Qe?!¿9?%5?N9>?G$;C?]gEi?.<_ J}? [,?Nz1E>1^>:ރ?>y#[>yZ><J+>,!=M=%KӺ>~>UN>un-QS>s)tD>Jhuxܿ?m0?h??g/??w ?R#yfϑ??'Wyv??2*L??˹tt??RI??ˢ?? 0??녇????<??^z??c??`?? ??ſ??\,:]X??5B??j??-??_ƿ ?0,?9??`1U??9䰣ϫ2$i?ٟs??9Da?EPn,7?|??9hpP>Z^?)\:??9䴛Œf!?4-??9䩺ͿqG-e?W??9>ou.X?J??9Y:v*p???9{Ԕ???9x9'},I???:M~ǿaL|?o??:OgZc?_??L Da?_??rrt/8???DG)B???@???:řݿg???:Ebf_iҧM6???:073I*p???;{6)P@ ?_?8 v?)?9ج{??;="?' iv%?!p?R?o??RD0?kɟ??`Wy=_?W??!߿ky?|??r9?tB??d4w?C??{{0a|?̤P??Yc7߁n?)޼??QSGt_?K??OrH݌v?Uw??vQ%zN?/&y??xqj T?׃ ??<$=???)T3?Φ??rEt?m?׈*?գ}??>MK)!?Q??D>id78?Uh=??_eϠ?#&??{zѣ-`?_?yUT֌?{?? IH?UgG!??Eԏ?r?if?XPlܿ)_Z̿='?XP LU[6Z]F?XP 4D{\'^7?XP+#![Hq?XPNӿeUo#?XP .2kzDVQ?XOhldj?XKNUqſ78Dܷ,ۧ8xpk8YBY>Rc MV1A-at' ?$(dc?Z'Zv?!^$l[?3o8O?Qbin? X<>%z? ?I~? c ?%j?9IND=9ə:?o?I:{?2 [怡~,q8N߉hwZJgITa-MVg)OX0IJAFt *%䑱 bX?(?2jM?^tV?'S Nދ?Ct?r>/;?4vd?s^?lX?q3=z ȱ??J [^9 tsa/Jrt= 8p&xCW }>A%@(>? G};a? :ڨi? jcI?gj?qd5>$vk' >I>ܚ_-]??v}6? ~}?UYޚ3,%?r?K|6R.pʿgUe9~r`ql*GK5R7]+- IoQ+˾е4?k->S>`>ukB>zr9>ޟ>y>rs>ځT>:5>P?D>; ,P-tG6??K{i@}{ oTv5m@ePIP%6>&IF@<>J+>T"->.S>߱G[>R߈t>ɾ 9>D$>~-^>J.>#Bs\_??K".yxD]fD4r-\jO|?^0& wK͖ ybPq9gX>d>Һ8 "}>8>!U>е8S>B- >})2>Mæ4>NJB>b#j>u:}%&$o(~?ȿ?MI_UU!?mj?e͓CK@wz˿yW`ھ+Ճȿ'[Ԛi '8k߾vX?]+ۭ1nz3 &ɰO}@J8x#'K??Kݫ˂V?f܉v ?K1i?dB˰?FI/?/ql7?N\?*:>OBӃ>&>}ƾ!L_,i"s n^x!e jmc̽ &) ^m7s,?K9$>Ka`[?y)?ɶ,?K+ ˷Ê=?ݞi; ?obێ6?Xe?hply?Q'm'?@3/K ?2V@C?[?k N+4.%$;rͯUPo;7fѩ3{+}qǿq%=%ߙ,q )7ͿΛU|d$$+?y,"?K-l˻*~?C[Xy?u^ ?t4S?pp?XV(?F:V'V?9}? ? xJ>TR;,vJ $e`}6*!PWQwTaK W,b. PsEtZ`Q `xfzZ??K.xͿ ??y6׽M?@A?s_K;m?\z?Io?=a\:?"jD3?NdRb΂AX1 a&_M$HEoXZWZ߾aaolfCH$!*Q-Թs)WdY??K.݉Ot'3?w?}w?WۅF?vOw?`ʓW?M=t?A;v]G?%Ab?#r p  W"ҪMtܿU!cˢ쫿ox˿M"5d\\ҿ^~Ҥ!LTֿ u4)+>?+?J C2H9c?IQ 1?/!}ۙ?GDOr?(ɣ?rHQ)?nl0>>޲Dɛ{>֭ 1S> f>ʺ6A&.5>N<y-9돾][=ȶ⡏ˑ Y1Gb|:ߢpJ1%V80m=\e%_O qAs&,ܘݾ񪏿ԾvU$;MNazؾRw{Զ!-MBo"ZfE+H/xDD[21vՌTы_TAc?K2xo>1?/?h@x?/oYJU?bnAB?K3t<л?9KV+?->Bl??[slYTۣ ɿ4~EϡCþ Nuw8T 2A$OMZÿ)|ςi:W1;-ۆſvv@ ?= `)?>D >5$<+C"&?lsl?cѻ?x;?vG?w=w$8`?eQuH?`<+};?@ae?6ne1?uE?yD&> O>Wad?;t?9>?+P6=`?* ?( :??RAI?f ?o9_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??֔`zO??驒T0#&/??J1:??׋G.rR&:ݿ??ltc T c??ւ:lX??qӕV館Ķm??Aқ?심lY1'??{?ӗ:"y G??,?ԀַcuX??u?֔`zãb#Q??΅?驒Vle?? D?J1rŋ#??@?׋G.1.}??2?ltc VwpG??/?ւ|Oi{c??$?qoX;yKg2|B1셈ֿ%E??yOQ?yJf?ʌT?@[??\3?0?|5[s?D쫦տ3?i!g;1v68*wI4ia§2ts_Ͻ;a 櫿'#fP ߿2/=eZ=ƾ*Sܙ$Ϳ+|U 6)u3V hpZÎ kx)ym^?|??wB.?Ϟ9F?1O9?i=D$T?t[?o?QqpF,>SF>6TDѦn׿A2J>@Yes(n4ז F=At3lSe{?{VN07>16CYhq--5K,%1I!,4?$?,?wM `?#X?%*?Kr{?j?3vX?ˎ2"AD1)Yǀ'M%[>#X_!r!IP ќWn`+8NƞݾM3FS@AFؿ&=.ED)w 6Gi??y?vo?HQ9꿃TL$wl9}9紿5g?%`@g!?zC?, O3?)SA~|?$aI`?"lҙ? o?4?s+A>v.>&{H{>UV‹?^2C?6(!?8r?n=? 멟??]B?vv??.eDbIoAݗKM٣1?;_$?B}?-?@d}}?:ğ) ?81?"b?/hb`?P;?<>!yS>?1L?03?&͙֮?$.۟?^?&?uߵ?w ?ܮ{z v}Թd=ؿ=?N5ʈ?>JN=`?D5`P?BY?dAP?=|4i ?:ٲb?$wk?1TH?S? GF>1_>>A›?3l?2f0?(#S?'*M?o % ??j?= XI?3e?2W1?&??C?۩?h@qRRw=ٿYgh?H`?QLrW=?N܃A?ITۧNy?FSpA?H%?1yoM?=~)¢?$`? @? p+><œ?@X ??bE?4ϦV?3Aj5?(٬@?6?K"?hy?;G:}jC激+Ƞ S\yg9LfO?VcD>?_"ˇ?[ڂ*=?V8N?TK??hx?@0?J:E?2d?$ӈ_#I?[N? bJN;?N}H?LjЮRJ?B1%"?AL ?6X`????=dXY,^p[y X邈łbN$?QD?<<]Z\?1]?&??H?p6f?I"$9ƨ^.},luӞfD?[cJE# ?c<?a X?\li2?YRc?Cf} \?Pc~?6)h8?\yR ?)el^Y?S\U??R07?Qk.XQ?G5I,V?Eu?;eՐ??ݟ?%?8fhHtIpZp)Ld?`Y?fb8x?d = T?`|?]}FeK?FP)?S?]53?:+?.|ܴ?PhMj? ѿ]]_?h?V byI?Tu}?KAt^?IeF?@4 ???* ?qj7wJ¤w XT5㋩Lsŵ F?b?j1F?gYc/DC;?c5?aS8Y?J{ ?Vm}:tW??.g"?1}X?#Ю?_O\?;g?YȋT;?W8_?Ož?N H^?B6|tUh?l@?k,??wE960ܿb)FqHv)n?e9V ?m` ]?jrK?e¬i?c{?Np;F?Yg9q?A@N{?3ֲz6b?&3K6O?oɘ?Ќ ?]4z?[ Xk?QXw?Q?E<_lY$??u?ʥ~?y=[4 w˪d@Dڜ=aѪ,?Pzw?V?~v?T?8?Pں/~?Nfګ?7HGu?C ?+X4 T?dM?/§?խl?FHL?5=&?D?;pc?:Y ?0pX?Ӿ?n??xa?l*㿰^9wѕRE32aL+f?P|pV6?Vfe~5?T.?P7H?NlQ$?7Nq{?C/t?+^K]?]ZI?3Y`!a?"U?Fw~/?D*?p"?;v?:_3?0t*p?O?t? ?͠ Ye&/.^~Yɿ0ptfQPF?UFA<?]?Z~tX۸c?U3!?SɲXV?>1?IpҘI _ioC< _7⎿2%??,Q8Xpu?VDž?Ra6?t ?V'?{|7^?Fo`?{?xԲɯu?\]*+?j@3?O/y8z&?@<&o?1}}?"؄?oH*?mC=y?aJ Ń?`!?RCb'9_Ni5{` ou鿨3)@X yat&!`!cFʿ]j!"pKkCF<Ijz/leafNx4U+>;eTf>z1u4̷3Df DB+2C$>btaq?Ʀ+Wb?\?xu?j]??Cg;84tgWi5y s_dUvWb[CΎ9N-B܏?I? O5H`? RY=>jek>1P&c>! >'?V~2?Y?Ch? f>B6?3??Uޚ {ƿc"D!y]D&W|`hAM]d2,NłxM˖a>ݗ}F>_C>-ȩ>I_>?>3>;A >bʤ>CM?>/2>3*fs>p?$?5?/?[&¿^r%Wq_qp"pIQRZ<J&1ͺb>ͭ'?T$|?Si >e/맇)>6:{Q^>[ ">ԑm>\8? >p$>)9;]?]oȡ>!a?+??6!L@&`DQӿeh ƿ-bɨذ_=Cm*0hp`~t885>tyZ>7i/>h]> BW`>@?i[>О]>&>:BE>rP>8Yl >a>z!ͨ>>ܺ9d??Wb?q+ҿЇ"]XNrӿ}t\}UBMvz6[gs-4$}:eV;NACW>yJci>r>\A;`u>ߋE3>G^Eph>ĕƈs}>Fh>,> &> dd>g3> :eY?i?g&?eϿQt@jÿS~w \VQPš1瀁aSƙH֗2$wU@4>}&Y66>w}>o >p>>d(nO>n>}+2>ܑW>!F|>t>N=>֦D,??$?䃿F5jD~f[vA=3[ "Way.&;M8֨͂Z >X>PiV>,Ƅ>r4kmq>(ȁ{O>LYo>Z>௡)>٦̎a>R>RC(R>\<???`q~׿_VVϧƒ']vGrFF"aT ~6ת/72c6_ye OATp">>>;^><rI>Fd>= ا>M >!>/̎>Æ|>ؐz>2?#?/L?>Gv?dA!4?>Ks?Kkxn?!<{;=>уO >A`>ǍPGs~ľʌGc@ `&Zվ~ wZ/ᶾ>@e?I.-dpARC8#Zw- ^C3S־p5C[A?V??¿4k?i a?Vt%j?{is?TR^?4!? {8? PBԇY>݄OY6-bӾ}f\l(xPP yXH~ESoz PޫP7kǻ оNjN֢zDO?>?_?MH-#e?=?DoG5?i@Gjx?B36?"a?1V>vd>()njysvK ھ 4o:1C˾ȞU̾ = rE-:Z $GQ+|7?)$aE֯HlĐe|?o?sC? %O?.1%>f?\7?uhZ?Xj$#)?9Gb]?$ߝj?~1V>䠢-QUQhܾIrzB]icƣa]0)nXji˾S"0off1g~SﰾJ[ +s?S??#,uϬ?C#?brz|??`9ч?@(_{?+~q~?:>Jݾݼ<4޽.$%"]Z>dzMWx:'+~E-v[,^5׾աf%w9 ??,?#lV[TT?͎ws?d}K&?B?aMa?BL 9}?-6k DY"?rbd>Rk׬۳oa#KiY js`}a)7FwK* }|K^ھη+F48͸5h[~?‚?Ѯ? Zo?`2}t?gV# en?~?c+?D%ƹ?0hwL?4-3>̰4T֜A>6^_|Tާo߾-\UG$Ͼzd q$īaBb*5:MոS:ž`(J|˾T޾{+???$Rv?tq?7na"?\]H%ޒ?4>?S?O*$y>m%>7{YA aA4upǃdY)4!Y澢83t})wynhlIA߯åɫyy aʹ? ? ^? 0П?l;/?GO6p7?o) u?E$K?&rn?p>mY>xlMK¾4EدKo۾٭hge ,-tƾ,>eFOi_џYy~ۭZ#ؾەu9v?h?/L?"[/S?cc?MŤ}?qc 2?I*n?*=נ?"?,#>ZS}[ȁ^ ܸ43̔l?EQyB{e~p;ނ#[˾ԛ-pNEؿWoT/ߞ'Q8o/6?x1?o??%Ӫ]r?g2,?Sw;?x 3?Qubmi?2`Fo?zm9Q?l7>ڇg۾.hߎS SQ_-lp0K"[s{ȡRIs窾 Ctwu࠳ȓp쿀h]پT6H?o? u%9>?"D*ѹ?U߫?xP?R@*`?3Z$\?APs? f;X>>d)ʡO@u`v|i׳ًR`#5tFn:(A-yXWDv읾Їы匾>o]SտpT2??>-y?sti>ۡ>Ф8H)?;.r #?89Ay?%k@?$U#_0o?BCg????O挑 Q?.?Y??+?x pZ?8n?ʕnǿʿzx0[rQUs̀?W!֗?[5?_+2n?HUZ?So//?8k]1?*'m٘?%?Eab?TZ,[?W/) ?I^bEh?Ku(>?;>o*4?ߩҕ)=? WV_yB鍩濴A6ZۤAe'[E=Oq2/%J?6! ?=}(4?@d(VU+?*҉?5FPE?6r? ȭ. >LMWD>.@?6Yqk?9#OcJA?,0&q ?.* !`z?3s[?{?sWA7,??1 k?"Mۤ?Z|T,?Mݤ?L{w?PW0DR?AQ߇z?CG?3a-#Y?6޿iu?|^3CGEg5.ٿ'U.,^x¿_-90ol?=)bՖ?B=*?D1_P?0&?9Ҕkr? .s/?Ҕ?> Y?;'7A0??b?1Qs׀?2?"oO&?кN4_?J/a0w[z흿uC* GXӿ #xިc?&FF #?,Z?/1??"~-3?$!_A? E*>*|*ބ>F>>?%7m?(Xӏz?8Zx^> >.hq>Ջ|"8? ,E?nDzT?ķ9 5;:?덥c$Qb? O??f7J?z[?frǞ.?= _hX?_U>!$! ^zKWȿ VNX꽯\-˿Ru;&'ٞn>/UG ׿{;mI㲾 fg +FoOƮ1?*ےJ7???~2V0? q\?|Mmv?R%x?)jFI,'^2V{Fؚ{TB@4FSB@޿4^ÿ)~fA"e܂+lSHg~* ÿ.$N dyKY"JM I((ʦ?OBA?`?˯#?q=Z?< Ѷ?juA2?XN̥?2 ^3T,sX8%Zݿ; YG <%])1oqɿ27Dd4˿2Vڗ55Y& ) r.wAt?zΡ+A?E? ?ZV?xI?Ad4?iY+?B=Z3DJu*i%MS7?hŏcէٿB뉿(~Q]@_@= )-k$C䣁^F;"8ݵ7a;:]$3+^v?{ӯ/`?t?ZW?.LRb?RvM$?G?aW?9a&M<ؿQx[B;)F9YFؿ-#Q0Ȣ3`ֿ[}&VGN19JRá=XO?l0"9;9ڿD?_F:QR$?H'?^ P^y)Q5KA>Ɣ&rPCAͿ90>Nu&~wPR8E7?y?]d8?4zyĿ727>lARpI+:9п5>ʛֿ9ZS򙶾\8?EjG{7;!7¯):s w-4};%/٭MհNC2?O*u,? ]?JZ}?U?Ɇ=? K?b>k q?;xw>WJZϿC=zE響0ZJ;6R!lR),諾8}(T<EX@٦̤zfr1%ۿ3g#u8?߫O=m6?t?פjψ?yv=?5? c?&F ?e[*˗?=GAe))v?NvGO ?ܶfj?C? p?یH{_?ic?Av1ECDj }[CJXۿNPA{78ȧC3u):$XCֿ &vSw8:DY#%FD9M9ɿ;]@U,}+U\0|ʤ(⥫?[>H3?e Ry?$g?9?mP/?fn?N?t~>?pa(?=JdI?Sp]A> Z%R>^ U>R)>;:?Z0}?WAaZ?0I*_?,Z~R>ԷR?ފ]Z ?A.]?ʔ??:?3 ?[(?̎V?!?I/zEN?jT}?*!?T}kӒC<[ EAU(B띒>z8;#Vȿ1SRo:CʃMEkf!E4J2|<ۿ'*l0ѿ&<:`= @ٿD?یR?Zk?r2^?c-?X=\TK?ȣH׸?xd\bC?BuŬ&+S4!N1H',!9)liapm逿 ma;/,Diտ<2=>; ]Ť PvN|??Z s?b6$?(M_d?c-??\pP?Ntl?7~"B$@uտ>c<+8fA/50S|п+1)+!Lt ʾĔ@/_%- e" wi1CL-M Ӿz;SʪFcRRѹR"䒡/Pƥ?Ѣb?ZX?6{(QJ=D UWeFx0jr? %?-W7f{V?59?ndD&Vb? 쾚AO?U Q> vr? !hA>D >4>by>Ť+9?lD/? '#E?-l{?*m>M'{@?*~?Z _I?QUZ ]rg\pK}q׿Fߕh|?0I/?75.?;/E?5(|q?10?.Bl!?}M?#ScT? $; >>G7>0՟?&i S2?$vK:?]a?Kj?a>D S+?_?Z ?i0&yjuYϿ`]H6d2I[?2k?o(?;JKF?8=λj?$~ ?3+^@?1+L*?5m?&tj? }?q>6>\W>ᦀĄz?)aG?3?'?z8s?t1S-?XJ??Z ??# [jF P⿊wwoTg|x?=<:?Ew֍?C _p?>O:t?|onj?;1V?#5?1c7f?S3?Z5.G>.Ǎv>ԫj8?4--{?2P?(i v?&_3?X梿? ?Zq?ղ718lP윜;C*Vng??7'?G ]+?Dk3?@k2?=q (?׿e ?%^Fs{?2Ih?6~Hl? 0>&@Vo>^d?5?4 YY?)զn?(vqד?gڿ?`2?ZxT?W`=D{򬧿yɊKt&m :dFTJ?L:Q?Tמ)tG?R(7?N6W?KzLV?3fթ%y*?CdSS?B4~?7rk8x?66B$h?*|p??ZR?kVkῪ(Vt:-v Lh_{92?FUZ?PRM?M-TB,?G+/?E7#YK?.lS~o`?: 'K?- Z?!;>oX?W}v?Ht>Hq=?>)k]?b?$ch?\?s?kK尻n]B Eӗ=Gv$hDI?QND̦?Y>?V@OQ]p?R !ʇ?PAxS!?7V%?DkI?*&v̳?F?,l1?XxGD?%s?H(?FWv"q.?<ǗP?;A&?0_a;ԿY??K*L?1VS E%>ʙGlJO?T[Zy??^oW?Z|+?U*+~`?SaK?<u`5?H>:?/?!(?mhp?p@3:?ž_?Lk%?JIv3b?@ː?@8s3?3B)e6??腿?2 u\챕usy'=1tq +?Wq?(a?aan;'?_-3"z`?YK%}2?V&?cXM?a(cI?\. C?Y:;UH?B'O6U?Oy?4%h?&M#V?xa"? m%r?YI?RZ8f% ?P ?EQ8"?Dg3?8/ɿ^id??Z-?پ e߽Bڿ#r_,]WMg ?Dd?Nklw?K1 40?F ț?Cž ?,Ze}?8ΙE? ;*?^K?<Ňo?J?4ݞ?:I?1"*@g?0; o ?#E1?m7?Zw"8?aw}DEؤ2>͖?<ɑ-?:Aؙ? h^?1$)?0=Fnz?#kkʿΨ?T?Y h?ܟ`owB;׀x|dP#$KDc X]?J W?SíJ?Q}c ?L=A;?Iе?2jPi?@J?$W?J g'??A I>gzs?BՆPz?AGA?6AM?<b?50I%B?)T& &dx?B;mS?A15t?6$2j \4?4k[2,?z?)2pxC?X D?ެ>\^αs~`d{rpVgdK?Pb~?X?UxZt+?Q꼁i?O)v?6IpU?C?)G6??3>x{?G.?̔p|?Eo c?;כ?:'d?/kQj?f]?Z'41,ſ%趫=ѿ[b~X῀ˮ@᤿r9n- ӿ`Pe![- oɿ3d:7DS54 {LEOdE ђ<eILB2,G`8O:% J7SWC=Ϳ%%O,V/??X1fD?X g>!>(b+4(A†&w> ; 0ϛ!3jkKgw? K?Y??Q+ F݆Z}zwr+ÿ׵ig$ۿo k;;?2  ?V)[!?]#֝8#?LF,x%if?1]QH!d~? ĩ?zK)K?T=k?Y a?L>G?P=d?@qqT?43?S?R7!3\C],N i#WC[cSg2jS|)'N E?.UI?:F?A+De^?1_Z)s?9iu?#v 1?#P0?7?>C(ؼ?9\\ Z?1P٥?3üI?$P?D5?G%?+~5-?OԿm䊂 +д%졒ٿI_v|щub&g??) rM?O[?Thf!?D7L?M3Hş?6+I@?)w? ={T? {r➭?MHEe?RK?Dck?G1g?7]Y?B?d?);'»wrXdE09nC|sPs9Fa`mvySjٿR݈E????{?DKr?4*z?>mXcb?&VBd? F"? nT%aT>n?=98?Bj,?4Ai?7rlD4?( Q?r?(?,'αЄS}ݫd ,Lܿ`0"3xM$[Wп"A<.?Vl\>x:w@?,J?11a:`?$5@&s?&YdV?gdY??t?,u P9z~ĿwXwaEXv4ד[PʺCLѿ5]"(οw|]>zS?!6-+?&?P?`?> 3>U40>1$<?%]l?#TC?(?YBܯ? I??@?,ǿH?vNb?2rkW)+?m؈?>5g|5?फ़`?U#㏾ipο y?|,f]ay;Hf nc"fPdzyK<#cоO2 x :%ْ Li#ӣ%i’T???,aW |[?C}(@?xm^|?!t=,H5?vON?R _Z?57JzGҾ$ee!M}6^G*0&04;¤Ͽ ?9bd: ˎ7P|ܧѿ 7}&"#}ީVW&b"+ N`? ?/L?+T›}*?_w(;?'nr?37D?&'D?\9X|?@z[RmQp+==` 61ad喀!a!p)nuK_<Fd ؾG)5'? $)IoZ /a<]!?zο#݄cD6;j[?kJ??-aN??וĘe?Lb?^U?FG?pڽ?TUK0AYãҤF4DD6ɃSD@"(hΜH8鍿 |0+@%ۥC^)56c59&:,*4F???+ ihG?R?!>l ?9"L.?8~8?fc?J€O#6ſGd6ag/U=$,5$[ (+/ 36}H2H̿$$\95)ʬ:9`-1su0y@0ȿ!+g;?h? ^?RT稵'?mh?еh? ̅AM?=*B?t#?X6H@ؿ'DnUr(Jg8:;fCcCFN>-AP, 󍅿/)΄?^??䪶0?)vr?eI{>?%]?)=v?y?]Mr"JhI,*k P@ C- @T8cGLJ2>#s$׵,2x}!rJHW§Ld^tL@JD;(Bw/_3j ?*!?+K?Aa7L,(?4 b?G>?˗>.T/?^*Wc?{Rz?_8!fRؿK,DQ_A SIૂ˿3Sп&Y†o%eL?re7J0mNVBUښ@3D封aX5yk:??;H?+^RL?Y?S:?w`4x?|Gr?Dyfm?~g?afqr苿 哮M/NLMS8ܦCv'L͍6)QN.S))enLyE1 M!fvl56M < Q/!ʈDvݚF[s83V9?S??-gmPU?ș\>??i? 6?b- il0?ELXRN1GX0791,NKEp6 _Fn%dy^axd1}3:ưcq\4'R9&ܿ*y.GS ??v?1 1?лyTo?u7ʮ?6v?]L0?g_Dsj?L~l߿ﳁ7"-~?5Ͽ. 6Z #l +2jAZ庿?ۼ뭮6G{:;nŚ*tc҄޿/V=տ1r̿!G8??`?0I[x ?ҟca??`RN? ?kc?P-{B@턿;Q6 m5AIՄ1]~nĿ9ǔLO#sݿuOnmjh;q) :3Pvƿ?ScB2DBį1Ji4/%.=%I+@??R?2g/;O߾5Ґ&;c q 4{EmH>QNﵿBwT52ur7F;&ƃ(,&..?:Ф?:Y%8?+m"/?f9>?=?U?qncv?Tͅt7dգA.g?Fw6d+)@b)0)x Z h_h{@| C/ֿ7/yk9wf +BÒw >?-b>-Am?K$T?[|?M֜>?30[8`? rkoX?%?~Xb?xRdk?I|?`/use?*& }>?ex2!" >> H!>]n{!?eh?cQ:ié?Pt$t}?O?7SU0?C?#n? $??86?1V???sq?6`?,9F?ޝI5?R#?C???m2~ ǿhGY-@-kX1krr\T5cϿqhGeRn^nDd-^kQ؏SڿIŔ !@l ~2pn3ne h4m{gݿag11n\?O?ĽR?>?Ǡ`(t?t"*?tm??'N?ayǚ]Kcc`ae!mfAOeZgZ0b,BR/OGFV>,}/34XcB@Gbk=Ώ]\( STzv/?9*$?ЎCx%?o?1t?aމȴ?y?tg? KO?g#OdL=%g܎-RoJ%Idm#AK¿a)kY h:Wq7nO}hsD'S9&LÿjVOhOr0ȿcn!nb i[T,Sи?9VÂ?'?D??o?2oQ?b[/?x}?1ނ1?XxJ%ſU_zٿX20/`#1^/VwR[ ;YOq> Iak@C)5x+f7+眩q\.0SZRcGU)2+T"Xf&WM2xY?9JH?ԟ Ӓ?m}v?jLj?v ;?L.e?i:q^wa?99T?зV%5^B28N@il?nI3?Dt:0*mm!#r6?U 0i<֓:;ULPӲ5K |4΍먭.V5zٍ?;'=?o%?` 9|7}:VǿqAWA9I?=U ?P\d??@|GG?F4wɍ?Er?:΢{?B#m?2PI ?(_ [?ϔH?3^?DfEI?B̋?>ss\?=3?5` hӃ?9k?Vϊ?c翰|A>qFhMx\XHYeȖ?C*U;?Es?׃M?Mɜpm*?MNUv$?BbGAl?IOCF?9?0jG?%{ ?\e?KA 6pG?In)?D/[?Cӂc!??=" WZ?8z%?;D*?Lg!7FIrgP7a {[SƏ?Vi-U?X%?`ҕ*zr?٭b?` p?TK&H?\ݭ3?M%aس*?Cl?8+?/\c%!?^yC?]Uz#?Wń}?VP?PRv_4 ?6?v2?u?2ڴ ( 0\j^Bs^^Qk?Y<1?[?bh4=?bO%??M]?WVSA?`Ev?P1{d?EIE?;@Y?1/j?aQak(g?``o?ZOs?Y+ {\?R|E*/x ?= ]?|V?жejhnրXMU^󄨿 4q%Zi0?kM?nлU[?tն\~*?t A?iབ?Ӻ$,?q鄏?aĽ?W0{E?N쨐y?Ckw?s1-sT?r) `?m-?U?k3j?d?z>?pc\{?voaN?f[;??]ۅI?ST ?H4J?xHyu?w oCr?rH?q>n?ix???Tak)ƿၶzGJ$7?uó ?xp6G5?nʶn?'8z?sֻ5?{RK97?kcҋ?ai( ?"b!?WI?Mь?}ǸLY?{N;9?vRug?uM Z?oTChأT?੷Y?.?آh<"d\!<zTϿnmAu?yC?}3?0?R? %M?w{?M?>=?pH2-?ebL?[uU?K?Q:B?9d/?S?z,$l?ySY O?r%ՠDZ1?ݔE8?s?Z1Jeτѿ C.:b6OOc?}6 O? /l?M~h/?^?z2If? ?ru??h6#?_9f?T2&?<}?14?(?~VZ?}HUHe?ufo!_>b?NR?6MA:?ytY{.kpHV7G`Ŀg h?c:B?eJxP?lK\?l1V?aUV@?g?X $?OơMD?Dr(\?9Z?i؟? _?h_8L?c8u_?bw?[~4|E6?H1?/A8?-qQR]KA:j(/g3?c^g?e\Ec?lПD?l-8?acbc?h}P2!?X;.4?O&Ih?D3X?: b?i6BTg?hr4l/?p?cw?b՘Z?[1jp?IOG?K|?%lt%6¿>j p >7j?jWUJ>?ml"F?sGa?s?h#g?p?`voK?UQ?LxD?By4`?r5?p`?kE1?.>@?j7>?c$:*Ξ?@?LV )?AW5_3?q殰q?p|#?k$,@?i6?/UvK+8?c .߯v?\?jLLſ>TNh^ȔE%ڿvSXtŦ-Ԫ?q-l1?sBR>?y1?yE#?o;3m?uuk&?e?\sX?Rk!y8?Gdc4A*e?wWX"4?u!R%?q?p C5?h\}dx?+Cْ8¿A>?^<ǜ}Tſ> 0ŲuMp|(":z M ZxmQwVT܃e#< 鶿Wʀ&Iv "<6FDjy j.}wk⛿v2`i?* M574!?_v6?v ?e\P?q@>?YZK?mԕ[?a$P?!:?jZ4!?u!"S?`Ψ?SmVf?GqhQ?m96#$?bwkv;"4;]K—9Lxfſ 2Y|@QxmmVcrSg<ڿWq0S?M,')\*Ϳ>ʼn tU򷫾څ';>o >ꚵ@eC1)Bdjf.0pn-%gcdPvkD6 ~?|?(c?T\ק7BF?dĸ N{i5b?0?LJ_?"鿲0_޿ư?q}ǦY z?1XQ?~9??8`!^ʿ}K?D̿k`H-!z?m [N|?{u9!ꑿ? `8]X?돿 xɁ Ͽ?LxF?;A܋9v (O8?-(╿9 7?I2ϘUjn 2? 6wn\?m҇VV:?ʧʿL?5ÿPa\Ŀlvb?mp?H pѿxb?/7???Á?R?Ș]X?ԓٻ?}āO?o5?|cY?Fe?=@e KohӿfU8XGXa7*9ܿPA=oدD`|89/RJgÍcZ֌ ޿bq͑2\Hkj++Z[{RN]?nu?ܶ?F?? "M? Eo?pQ/A? ?O$?9rXО4iZO1ݿ[8YѨ)\Kq{OrT "&B2} 6P,H!c~閿V.@rBȿT|O5MYݽnEKpa??[?.?+?-%s?VqVh(?ZZ?wS=?^7F?AR/Takn˿b&ʡc3CӈLaĪRƍU[RH1>.?\A33ۀCy'@M^oӿ\P:"2~Ucs̿T;bL/?y?M5?v(h?t?|ğ?U?KYrl?vqcO0Od:URT,iQhcPC&:}KÇ9=A~/ֱbiP#٤F)&U?qȿNwLM EεfDƣ"*ʿ=;;;?@??y\?H?}®;?Q*Bds ?h ?Aµ>HlF?9qK ,\-A+tͿ̵N sJ=m8nZˉG򤏊zI}Ά8u:N:*~f%3G"Bׅz7?]?|™?ݚZO?q'v_|ZU% 8TXmS`@%XkC?D9*a?ҶwN?E} N,?GsT?F*ˆ?8l8z?A??03d~8?$nŘ?yEU?9]-?CJ?B`Wx?<e\?:(?2Xڞ[?|U_?/UP? GUm?d-b9兿U(YZB@ ܒr50+ϧ+fA5/?I9E?I e?[כ?MY/>J?L1T(?>sb?F9Ո%?44[1T?)|@?!`>?z?Hk, ?F H?Au.ȵ|?@>l=$?7fC?? 0?僲:?Sk {Ij1u 1(V:@9uD?Xvn?X4Jd?\b?Ѩ4?[K$?M/Ȣ?U*6?C֢L?8B(z?.1K?"7?W?V.٬ b?P?Pa9?F"?+?.?L4x??JT1WmɍE[\}h~dB?r60?r3XY2m?tw}Ad?syMbe?dd?ng9?[L>H?\.~?QKF5?E!?:|dH?pW S?o|?h·D?fژ ?`D??pD?rН?2y 18U KmÌV{z?ujᩓ?uΘ?x|qN?wI #W?igDI?rF|>\?tz?r[QZ,?l1?kPmu ?c8AU??A'?yX?"tGݡ*WuXȟ _kGZB?yĭ?y€{?|C?{DeH?m@#Ӿ?u N?c}?X^1m ?N?}Y?B 2?wԹ?v;. ?pS(_t?p"8?f\J??G[?}K?(Ͽ<1j~z}ǿ,GR-yJRBE^fhv?}>[]?}6? 9b?}e\4?p1l?xaA?fja?\D6`?Ql)?EX?;4M?{/K ?youU?sdc?rup;?i2U?L?F?N!8?k_&Bnֿ4-y^%%HtDF?c@?cm|C?f?eu^B?W𨦎?`6w?NS3?CLh?8eL)?-~~ ?b?lZ?VWD?a[j?ZwT?Y3v$C?Q7?<Ǿ?\c?/!?ԧb?iW)hĶ޿?1#ù~Djl-)?cx?cw7?frO b?eLtڕ?W6n?`[e?N$V?CW Yp?8*?-J\&?bM?ae\?:L8)?Z[F?YA%n?QP 2?C?e<NC?isP?gx B?a4?a u?"[ϗ?Wq?/ĉ?P4Slw 62CLFiQkg?q4 K?q]6z;x?s&?rOe?c"C?m5C/â?ZL,?Pϫ?D.?9*b3}?pJ ?n"&?flkg?eԲ?^t*?~@MI? e?TyPS3v6&𿺜صNxNVĢ5%v~`1ѻ.jտ(nE\j1z"H.n,<\ZHOMvӐh?IS˿0{|M,}5љJĿpe 4?uoZ֔a3u2&˿? þ6Dk?Bv?"Z?Q2?oz?3&?Ю?~c=v?LFQ8k?f)V?s6ls`?[0D?PW??BCH1f?5c/?uؼ.?tFdz>b4$@WC$K?b*H)*R)\Ƃ#y5g?r??V??ikL?N_e> :3!5Ͽ;8k>+p?@H?n?j? x>>П?f')(?!&*??j9m?I2)gX?y?[_ySGid4n>릸Q1j>E>? A0J?%SB? x<>Fi #?5j򸶓}>9gDhǿ)mƿxlG߿]jhҿJJP78(j|>,#.??Ӆj?e}h? V%:?|>rj>*\?}*?S6Xf?/D Z?dS? MӚI?^?0ˡ;;Ƃq6,:iК2l,Xÿ{BQ?U?;I->h44t>? E?y?SA7>RQ>bI>e%>M5kJ? Vd?`? g0R?SԿ??迲~0Nheŏ P)1naj;ZE8uM*gx2G,"qL}Y>薪sC>= >jQ>I X|>a+Hx>o>֧X>&? Y&>TJiv?`?@7<`l/~`0[Wk¿@E Da޿,c%sp"pnun)fH> a">Ž]>x7q>Sq>lbT >ZxS>Ţ$j>dԼ>4rr>ٲ}>uY>Lb:$o?=?өy&SW鑿q{iOvt/3%'p t6 g迕F+5K۾N~kPͬ>렪EQ^>B?>ׅ>xg>лZ?>Ĵ o*>T f>TBԖ>e˾>Z8>HR=n\?. ? ѿ um]tt;0 .xW\57}ql:ͷ8˾ӛX98z.Ǿс>Іݙ>:M>u}Gg>m\MJ>5 )>KsANl>YUl7q>TOVt>WZ>Vk>jp N??{ ?GV:E>@&)N?-l-=P>7[ i>'s!P#>ےOgྲy0g9eLEPy㾛ArMNtPBaFP>pk=Z>oiMJܾYq{ +˾WcAsĒjQ%.Sn>/hɿP_?;4?E??3eTt?`rԛ?~n[ۻ?[?n[Q?@T4(~tU:)lwC5bJ Y)ALЊ&!8(jHʕs'Oɒ?;? hճ(G?kl?L]_)~?k42^?G2)!\T?,-sD?_Bc?%O l>TE:'!4J%tǾH޿e$k ̵l?p{;w3fdԾb1 DmPQ",*G?H?`h!wZn?qEq?eF-n? Q?aұ_?E5-?3.[j?"+">0K*ae +WGC|uKG1։1 +~|zbH0 ;RZ1il߰(? ?i̢jy?'H?mV:E}g?}O?g4ma?M)3K\c?932?)U??+?-B"⎿#iy}ӊ7no.}ž):LpXvl!hwZvbx/1̦9??4?o~x> ?sI?psg ?w! z?jޞ ?PF׾F?< ?- I$տU̲yW%Fƀízg` !6pL~.,ߊNilS/Ba}P@ݿ@?b?)soz?)r!?rV=?ծaY?nxUyq?Rٍ&?@kCW?0jT? +L`PN>ȉԂu J&~ljԿ_= b$,0Q3+>W ׯŃ@bgE ,3E .?. ?솿F)S?r ??t{:D?]W7'?9l۾5I?C}? u:>[S>ԗgc֖fӜ ZϽ-Q|1W!U= $4 PfӸɁ'`?ҨMlX 瑚Q-WT 3o??ЬŶBtb?^`,?PkMx?pm>?KH?0*5)?5sf? ɷ>0} Css¾8 ,;`F;ɾʁ+D显kSoQYܾN,ؿ} (\Jnf\Q] ľeEB_魙GU ҿG@B[+U{&tы?);P?ѿu4{u?g:et\W>b&(8\%+ezKf?bL*\]HžV҄⿐1UOCv_:8Y?5!w.̂?_לH?a=p?~ ?[&ԇ{;?@?-u b?_>w>[޾CoCϺde%?Ot5`q?~T3V9?gU?xJ?qF?kA?Zr?U@?/o p>;~lu?GU?D~d,?3c Ih?2Na?!߁^bT3??'€a?W~9? 0'?,S?'3}? K?Όu-b? E}?4rM?gO\Sf?6:7?Q.GO@%1D!5BUE<]?n9e0 vM5α.;@쁌z`o=[xy i:Һu1bނ0I Uɿ$$zZ#6Xo /_?V?7d?Bc?F?T 0Էl?A!?vL(?>P-{圿2[{Y[03*)n) .aJ&#kX ]W׿KyQMqg @髾b⭁ ƿiJŴO3{emć*k?f*??x%B?_ә'?ac[?3Je?3?I-?y;1c5@ >Q|m{5c6-3=%u4@i01[[/?m<%?E)5K?#(,\?!ږdh?1O(?#&>~aK? ޹u>3uQ>/Qw_>kr >?ܹ?Vqi$?Swl?V>[?_?P?&M?1S:s?/>?]YΓ?"qnNw4?,';Ϲ> I'>ͦ]z>W=2tc?% C?$$.җ?l? 2p? :v[;??l?Z"#k HZb`\@/0yG?7B &?=|YC?9}T1?HC@?3R;,xa?1?'%?%B[? ,i{ׅ>-M)aP>T>ۭ; ?(#E4?&1O5?JXx?2I-?D<]??#?} +bK'QijSRe7T?Ap?F4?Cjj2*?>T?D[OV?; 'Ϋ?!ٕK?00|hf^?O|?,Xy>l>75'C?3R ?1hM?%©%?$nQ?5? ?T%? H꿥+v[k9+57/5RSqX?Bts-?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;(w7rxV<翛,4a^1&?P#w?U5~?SVa2?Mhl+?J ;?1~?S??*,*X?"/7?Qnf?MV\>eYY?BI4ug?@nnƣ?4?3Ǔ?&|(N??z? Sj[4s~j%!;\Xh?J:+q?QPM?M/B?G+A @$i?Dte?*翭e?8X?+^?G s[?pġ >m̿>Zւq,?<Їl?:jAu?0s8q?/*Y\ ?!s?-? 4k ?ù~ƿ82~\fP|zlueꡙ5zJ?T^P,?Z~gh?WM~k?R Y?O(?4T@?C?&ˇH?)(?F%=h?q^<6>at?Flڮ?DD۷?9n 6 ?8@"?+౿E?*$? i&?iͧ@ooB蕿$3lr?W ?`|?[dW٭?Ug8?RC?9X-?Fs_?+d`C%?<&?q? 4AÌ>:;ө?J2?I 6?><3LA?T~/8>?>Y??:%k?Z]@H?8TL$?.O=?-kW? -7?U? 8?[vI |Vr2jDٿfBZ5y"?HzGl?OUƃ$?KS(?EЁ,?C%2y1?)#;?6e?UB? j>V>ޟa?:A?8h?*?.lƴ ?- Ē? K?>??7B3Ě9Qw +4m޿`EsJ?O^B?TE?R(6?KA!K?H xa?08a|z?A`Åj?@ z.N?337C?|p}?2rl?%+.ſ?|?3.ZU?J)y1ymwc HP`օ\\1?O}$ ?Toe0?QD ?K 2?HH?0"ӚY?=uC?!A?Ce-?W >G?AIBt%???3?2? (R~?%\Z.%?u?' g:<}JqZ*+Kdu?S.?Yqb6?V`A?j?QOUNw?Nߺ?4 F?BVHk(C#?%Yz?9?w]9>p ?E؇Jl?CdYϴ?8?7GK?*-?Oel?C ؗ,9ڟ2$,Wb݃e_O ~>ƿp̶:6u>C C'>JbI X势{`PGmW-Rֹ3"kX譴SsjSo?E8pH׸?F_?ML%"?g8ֿ.wοܿ<ʰ#( p^n/>&?m\7Ι?kN9O?lw?Q2?^z@Z0S?@p1?04!D?[2? /n_?`w?c%݃i+?R!B?Tle?B} "!ȿS$?@hɌ?[F!rW xZ~*Llc5OLX_᚞?QJHW?Gc]c?GW8|?G齊?.t"I?;Kрp?]im? [>.I>D_?=\y?@/%At?0xB?1q0?!X➈j?>ſ'uGK?sC , <9CO/{/2e2 H.?G\?d?tˮ ?bܙ G?c֦r2?G U?U{df?6{P?&W_?U?ir?W~Q?Z3?JA&&?LcOS?9'_z?ݑd:MJ?,gw9^ȁlz;x8jz5xr놿Re?έ?P󬽼?O/D?P|߾?4M"?B-6]?D%{O?FW?5?6nF\?8q?&=??C?OF}4Q?ϿxUgY"|6&Lf!3>V95O|U9>"i ?1Z\gt?1'*_O?1scL?bw?#8gY?M1]Il >o>ʩqY>|?%f?'~B?Z_c?vG?GE?̴+巏͂?"?8G=?0Cgd\?$F0]t? A>>PHKHUͿ#&WU,5+^˾1پKe-$ 7vr㾲֠8E[)E+UT㛵&p}jSФ֡a(?ncl,I:?.W? ?b3J?^zv?XMt ?AG d\(Q-,ue٦ov:0xi2L"_I#nՅxo?QCY?>?-ʹ?rѸgG:Ac=1Fрs&2x !!*h3I ]?7ok??S5?w0?LEq?kX a?S>LO'>P8 }OݿPS w-qL4 k;BvO#oRdh¿2]~s@C!8ĖlF.3I6>TMͿ7߰a&  e8?Ԫ?;?%(?Q,'|o?5?zUa/T?bs^(QYVt_S.^tw{)_ }Ci=^qg׿Qt@.2r" ҿ+[-zS6@`UA{,f`EGA<]5|]?> ο*ut?o?؅VK]?s?Hx$?s8??ZWS^F3YsWNCIV+V/O<&ϿIP'6V+W Lx<$ fFKk΀:N'rX?I^@Ձ./)J `2?~qA$d8??v ;s8?B`?!A?NX?f"`t+%4_paytHAa3b'G궿Eo SS[5rȖ J%ٸ C_dV3i~U zwXaĄHXJ:489Lv?ڡFB-??e@?)xy?)O?숲B?{:?fV\M?͘ u?pd?iQ'n?pЂr?9`Arfٿ --?Ϝ;?t(eYMR?Vh|#C5`**t??`??a?^9?C?6?t/?Fc?;BH?vgT?L⫯?<? #)?ԏ]YB;53?OOV6?[?+w?GC0 ?|t6}?M;\:?e舿/'! ??6?PfA?h{?F N[?nTH2PJ i9ܺ ӿhpuſiUxyO$ǿ\ey)s?CWO.p捈v [(~tg0ni_Nnp)aBGOQ1>R~颪AUҚ3Lԑ?yHu L&??㵽aoT?|0c?A*?pR) zm?Vv LB4 S#R^z`-S]oǮ80$5E礣ҿ'{v.FRKnj\XUdGڱNlL Jn+C:ENsÿ=%`mZX'Ya%tZ)E@dD ^Mx /ʘ Bڿ Cg V0P?r!?Q-BFۿ(f7Ci4G2Biayo?ZN@8o6?t?Ƹ?vh?p G?xjns?a~e ;?Ta^#|dڛ\6E|^A#Bd$3}iP$1<`*ſ! kBqP4޾4ivER1c?T%QQ{ DkdڿEKҿD~hõ4UZE?gSn&C?9A?MQX?$+ ?zhe'm:?cr[t'Q^ SZ^jQÿ_qEC:їQlֹL3 o\¿#EZ9JZ ]SBfUSXFMG>Bcο6D܈̿ݶ1Bȿ/ۃ?V>A71?I?M+?1 ?:4?^,H?suD?}H ?u >S?,>K\/=Z=UM5ܡ>̻ ,>s~;ӦN?!bI?HT?Q2za'?p?]??ϢW?lkH?>N?yӎ?dylzx ?6 1?H6IGCG皹E:mb+B83v:d6q .ϝ^%D)`. ukrro mU>Nnҁ.٘|P,a:P ݿ NW?,?ϡ7=?`i`?Jp?PQ9%?GF?tu ,j?3]P ÅϿ ILuf4ܿ?v?ϡ=gw?ix漨9?!@?]ܡ ?Q+Y?9aM?ACe??}Կ@mk;er%q3"1q9,Y#S.putz-4uSRoߦuS-'Km6%Z6tzۿ "ޣ?L?ϡm?d0k1Sh?t-" A?Q>׀.4$u>V>Ge >`v?%?Pdioє?o3Fn?S1i>4t[Ԯ(~??ϡ g?g=.ӿj ][3EA3?<\qR}??w?iuO ?:N+?3C g?0\!v,?Ҟ!>":>5D?& w9?$RШ?WK ? Nߋ? DCݘ^/F??ϡR?eVVTKV+nDR`ƞWv.2C' f?@S !i(A?A# ?=0?jM_?5>?2 |?U?%4Q@GE?]n>`T>-{G>դ9n?)N+p+K?'9?] +?#/:? lw%O??ϡC?fL Vn h؀`95KD-пMTg|?G=cU?I0 ~]?F2(y?@c/?-W?; \;? Q3:?/ڏ?*:l?^>pM>,o4A?2ȐeU?1DQcE?$Oz!%?#24~?e+K/?;?ϡJ?dῥ ,ۿjZr=O|%K?I4Rj?K_?G"%?A1mze?= w?Nv"?!v?x?0C?G i `?>.\ϩ>#K?48ƪ?2{X\"?%\{;?$Lk?lA?D? ?eEb6wg-Dx=[LeDw?VTJ;?XPb?TKeIH?N:,Ө?JT ;?.p# ?ZKJ_?=^^j?1`U?kv>Չ0|>3?Ad?@?n?35e?2 f?#-6D(?V6?ϡc?d 5z1SlrTn{q[f{bUSzm?Q*?SE3?P-?GZ|?DIC&?(X^f?7~?c?5qGEG?\66N>ٰ~N>`?<U#B 8?9?.J/CA?,W ?n4@P?-Q?*[j?e>l5@|k%o^[P?`=;_\?`r`?]]e?TL?QA ӑ?4W?CQ ޑ?$Lһ?Of?L?L@Sm>5ۯ?GXnj?E;TC?8[d@?7X n?*̽cbڿHxa?-߲|?fWQ?Pzm?NfM?AݛuS?@KD?2"$??Ϥ>?h|>Ҵž"qe̩6'#1Tq?P]aT{?R?NlE?FkQI?CwGe?&Ơ?50:.?3 ?P:>6t>X,''q?:4K?6uG`?8S[?,UAQL)?*̶R?g#1]x??ϦjL?gӵeo%qd8LￕϵwTi{?P^@w?R[?NAb?Fki?C]g|?&H^K?50?R`;?P,lM>Ub>W0^?:4.h-?8m*?ˊ[?,U:r?*!?fϒy7d?Dc?x7+L8?hUGl?GlvH.Q G{>ZL:L?Uİ?WR@ ?SٝT?Lো?I 3\?-2_[?<,?:z? 䓞62>a8>lxY?@kkχv?>O6:3t?2(dD? qlr?1.M?"}ܝһ?? X?h74\# Sпv&PӿQ]CZO-.?T|?W5*?S Y?LS*?Hi3?-a? ?<7{?Pt? zˡ>:yO>~*Ʊd?@s6?>Ӥ:;?2?1'D?˃?"atA+{?V?gF8W ѿ{( J+[=3^Tߧo_?[um?]Z?Yt- ?R H8?Oj2 ?2^?Ag 16?"8ZRR?KV?jd>Ƞ4o?Ep?Ch ?6qS&?5PDZ?'¬ojb?x[{-?OϡMe8dvnl2΅Ҥ}\oT; hyxXFZտS)[4y9󸈿"^iCh$z3fP% zksdA=q5xM8/HOYx4ŐS;yY^f~'B??, .Sտ ~a?i ?]ˍA?H?y}?`R?P1?qr?n/v?K=?]#?:lQ?)Fd-?;{??[:?a~?`*z?QDQ?PrAz?@z߽/T@ 4Džu./j;xfs:8ɿR2GſKp'40+dtY+WW#Z>h5d >dFp>6zl4>am*#¿˛cN~@SLbJóO3銿mԙ1(?+4:"͗?O@!?9m?2q8>iA 6 1пt7r%ܿ:|?b0?aXU?bE@%u1?Ggaw*?Tg+]?6zQ\?'$U"*?լy?FӔgj?V&m?Y40?I^x;\?Knf~?97MԪ?;\qU[m?΅DG΄C5ɻ;?S25ￃ2RWp/<\?? ??CѣdP?@X$?%ipu?3?0P?fl >ڞ+>˕wH?4Jݥ?6Lg?(ioeD?)9?98 uӺm?-r`?qj?qyο"tc]'7_|Ͽdc#u保i7↢pi=@V+.B2?Y}&?WxY?Ye6?@^8¥p?L S`?0vd? GA#k? =Lj>Y?NMKSy?QuM ?AȨ5M?CMa_?1&苿?-~F]SG(?] BVAXd }9h e}VP+P;p2k?Fi+x?DD]?Fg?,Fk?9൯?f_? >Še>襇1?;Q?>Яu?/^LXj?0L9?'!Y?+]ǫcw?ςKpeΗz!?>-o=H'];XL.^ =lHA?*8A?)_Q ?*Gz ?O> _?耺N?JhMy>X->5B >CnN? ?"~?j|o?ʰ?p+3Խ>m>->Y [>/Lw>9>q>TC#R[->AV><\>5t>4>ݝ1s>. tV.?+p.񱘧??,?q;g?6?scyS@?B\ݖ?lÿ/OCD0,3.Wo'Fؿ!2?N:nTڵ Erc~GZd~ ?Dj&"6A%.͔ef(%3:>hEC<y?-j!:bI??ɹLk?[I0r?k[.=F!?u6v?QlTer? L#AC2=л<(%#Qf;= Fdļ#1 EÿY rl`r%U`o2 47| %i)ɹs&XWѸ%?+*ԯʆ? N?u?pDk??2?Vh(T7?gCDd$BtCi"ӯOiG)))6F{5<ݾH &`ЉOש=ο8,j;9gg+ Bݬ. mǿ] ?߉敦5?,?>17?0>?ȣ?_?i?ĕ:O~?e6Z&S0%~AR=(SR" 9Y){[ǚzhĿF(kK<)4З_ųW$;H'9AHMJht#;6*l=վ0W繿,zߊW}D?7Iؤ? D?Jar?3%?? rH?_7m?hyKnJ1&SK|s23"2?ʶͱ$ k"|VgԿR\Ř6:)(AG\#3CE)04MͿ5k)$smz?TYIF?$k?Dp?[ϧ/k?uN=?-z??idע'?4cV_< UTRCTVpҿ=mzIV>v-DdFI jc9_ kL&X~ OZ Cw)K@[1ȿAmzU|0o FsrH??kA;??oE?T$<5?8?J?q\X4e?8bWS@eE&UsYP)+տ@Ud[MI ǿ0ގ+ݓ!忏Vnxg|ӜMѲC+QJA@/ CHu;G2th]|ՠ?$ ??Vv?+%+? ]7?+'tZ?prcU.Jtk˿M3H+&Ѝ-K8`[zkJ1cɿs9ÿ{ԔmUK8+&h7OkJq0B \jʿ0PS,,?h??Rd)?F,?1$ ;?C@n0`?A??1l#?qCˇ?XEUF25R?2~4&? qg?Ρ?]Mxq~?s1{y?s1ߚw?aCˢ2 {?' {H?$k?Ӻ +?Dl?i+?II??ZwՐ?f2Gb+d FY⽿G)LOٿ/lUJ;!->vqPJ`BZ<޾E)9ۛę= A "m @n [1"X2KT䏿!|vǃ9?2)׹}??؆ Q?70?‰Bh1?{]?`(@'B?]LDjIK1791Lꆸ?.2+%@o]7"l6{c0m3څČ,8ԳKA2 } D R^ʿѤ~9z4p||62NKn%g?΋SFv:Rt6SoZw9ajF}#,r)߱͡q%~=qRf!H&BK9nwMe-Q(nR 3]?♿645?>9oc,>&!K=1.a=s﭅J?MA?CTLn>,>wqv>{ F?#? q#`P?F?u?kN? Od*?_{o??z1&?ȫ/?T/N/?LK8?T^G?}0GrE`&Q-Etfޤh2{tnU,;tgcm+ld#skc4ȿe0]EgS[$rIdBrˈtDgs(J \pC ologe^|?7A?Q:??цڿQiZH37;ҿ?yiC˻g4ٿd@Nc<]< ]!+?jR?}{?L?̺?MH??>yq?K(w?x'{lMZ-Ӿ b˾WCdp ]p+*gKڿn`V9WO =Q DvupK5VaanWTuPj ׿h^c'66?҆u6?i|F ??Ō8|?R?- /%?]ɜ 3?$+_k?kwݺN E7¿UI݆ҿcXӟucpnZMa;VSK8+XJyȞA']ǿ7~-="bJaa_#2]YY-\P>LUƿT7s?8??;?ո?ZטuN?e?zp?TNou?4~5WV^?kAL[UKZSCcZp Is<^׭f3t~g*'2B!CKc` ClI E{E╁oDP @dxP?3?y”d?俛NJ2t>Eۧ׿gekgA?"@ ?\`&)?**;?78]?73w ?1AZľ?6 )?)aH?!,(E? 5m#?t&Rc?7L۽?6碾?31Bvʑ?2`d8?,Oc&Rӱ?T?݂?pm}qޜe9tN6?/-?6:p>_?e?Dp>e?D0N+K?=BT?C 6y ,?5N/IA?-%u3?#\O?ba~?D83 d;~d/㿑hAܿilEǥ?JL?R?`?a ?ރ+HP?XúSz?`&od?R IW=6?H?@&k?5G?aS)?`BzX?[u:9?Zi˦>?TR?w1?ɍ?%X?:}}㿱ۿG:h,(؆8D~ExyX?`w΂|?f}[\j?t9ma?trf?m6d 7?c?su@C?e'*0?]ۨ΀?T 8?JwYЙ"?t ?sX"W?psH?o#!?hg݆+?i?3'?ҿ<$ʿ꿿SźOjɌvc?WOZE'g?`s_Eԙ?mMN?3?mP";?ej=ʥ?kvTQ?V,`?_$?UP[ru?Lx?B6Ǫ?mgD?lE[?gȎir?fύY~@?a@߿n?鲙?n ?ֿB`#bʿ8]tG$j?d@c4Z?m; u?za2 N?z?s0 ^3k?y ~f?k88R`?NJ?cʦ씎?Yj6?PPa8-?zyn1?y$ I?uXT+?toB?o{לEԠx?Kx?W?}Ii`m Y"GOeUD??iu`@?qE=$?5kRpG?8Bb?wR<8oy?~p?p O?g4MC?HG݆N?_?HG?T!?*`?~RA?y{&?x-J7?s!(2e?D!?a qx?f0w^ n6a6i^+="I䔄?n~1;?u|e?lfL?ltU.?{W%I?7>u χ?tF?k@{?bsĠ;?~H?XEg?Y) ?EIw? W|K?}M^?vt7i=??RP?i=܌0Y=^׎1]`rx0?q.?x]O?p*Ã?l?MΣ?n ?wdZ ?p=o6?e]d?\g1?kjX?TB$ ?Mf?|?#q[5?ziC +i?cl?C_[b? ֿ/+ê nWRric4s=ko,?U!?]`?jͻ7<ʀ?j5?c_)?iD!o?\,>i?SHfؼ~Y?I?A Ka?jƄ:=?mT3H?idX?ee?dc`?_)Gݿ: k?K? ?9Du?U-|B?]?Ez?j/2?kW[D?csըb|?i_(?\JkR?S\'?Jy?A*e?jB$?i~*?t??eky?d}0JZ?_p:>ol?Au? q?uU+u;K<,'uf|?^7 0 ?eT?s4H:0u?sBa;?mlk#q~?𧎣3?fL8I?p1Ӌ?|rE]9Bu~ڿʮզ@(lލz?c?l^6?yJNy?yW9-?r= ?wHDB?j&1?b&C :?Xr,y?PDO?yF6-P?w 3Z?tHE0L?slq?mm?߄?]FA?bO bGkо 0> ̿fd9N&;b{Ū]ܗ&#X*,㿙W 1}Ëll;ˠ{c_R*DFqTl(s ]m0}Xc?|7HRpq?[d 6?C??c1|X?%~da-?H?> Q ??񗝈?8R?nBF?wKB,t?c|?XiK?Mi?Bhd?yo=?ym?pHM~?p=t t?eLNquƿ_kg.i=$ῨbКL<<Կ~vٷp.gljcIZҐVV/K+y*|*B7rd$ צ+8qX>39> \F5[Eٜ\2F_ 1d YmcLĿҷP?;?h?=?ie̡ܿѤ-q#IU d41𸼿kahhl=WJ0?H~Ul(~WeAܿ?º? K6nU:?vq?ϩ&&?":ȉ?@gO>GW ??5h?Z?f[kc?!c(t?6|w1??6-!_9忤٭[ et`t0(MZǫp ,cTH~Bd@2Y5Ǜc8ľ:s{p?{_ ? 7?W?f ˞)>yve>[>dN5[?bGʓ? یLg??SЧ"*]??Hr?:C;ÿ*r_&h_+W&kbgֿ|*LVBa$D&TP4Aƿ@37v ̦̿*?1[9y?jH?]? <ߎn?#s>{t,? lU>Y?d:l?Lw?}?xcF>p??GlNٿW䯫XK%+utܐͿ 9Uqf/VٿUHCŞJJ4+巫'x5N9?|9r.}? ,Fs?h5"?Ky> 1E>ld^>Uу?f_? F(?o{?y`??H1?|(C\XGj觉}j7߿e'uK :8>M)m)HrWK^T?&*A?6X>t[)>36P)>K> >#"׿(?d{ͽ%?voR?TC`>|Htп/L?o?HgĜȿIdA.Bq6$п`AHuiODR:f2寞@뿪zoŴI"2nH;ТfTD>4&֧>E%غ|>|Y7X>5j>} w>ھr3>Cov?Ic>JV?TKC>: ??HJFoZ7H;=Xj uݿtZ7QSJsZ9m_E&*\fׄ)ͿNv"iӷL|9s>lVRg>n-i>MEow>,>.}Od>'Fߓ>.>jP>>m>M>fq>OKH??Hο`js !TCMrPY_1Of.>x{?z#풿Y| oJoRO ?>ݽ >C',(>֧ >Ъ>@ j>JA>`sG><م>jԁ]>ĩ>չ( i?'+?Hƿ}ܰ8*ӖEO*f|e")ow6 {,]a,O&ؑC W">W0a>5$y6>ҲVxO>~{i1>@n>+>Kq>x >< !X> >qH 4=) ??IYlɖݠ?E>?bV!2|?p*?]E?CBy=?1\r)?!q*>ޒ >+鴾VQ8߿rY6ҍվ>%QS*\IQ<'sA=N-T`=hFU gFϙ;uJ|?t?Hw;Û)?p뽑?N?jU@>?H!@6?/iq?5ݐ? <Ʌ->(>dѝFn+@Z`n⿜q:D̳/^ ƾ˱`A9PM.*ᾊ;0/gmid? ?H$˳%Kj?חK?i?*$$?d"՟?Iԉt?7$ to?(X ?ǂZ>/T(IŁҵ)Y+Jw}jjWΈ޾by־62Uy|U[R(B1>xq6'??H~ ׿uJ8 ?y)J?p򧫉?C ?k+*k?Qdi??K6A[?0K? LDt3>ob4| E>[NXZdwqyBwTЦ2/lEjjt !HךKl˿ ;~l\O9B?`?HF"QD ?^u{w?sPX*?7p?n?S6?A?2rf?k$ )> |tGp'%߿D_xTZWпcuC8L_" žW []'ż.i+%'\)6Kh?Դ?HR˿`~?}o:q0(ҿ Կ ā[ rBPUþ^vl!Uv~+~-N\L*3 ژ$X y %v't??Hq=vp֓r?pv;U??eZL?Z ?932? Q? 6y>SKֽ5I>}>7؈R~k+w \ӾʣLFJQT],x!Dkh0wT͕q?Ŀ-Z?/L?Ht5u?cjz?QkC?oU%s?L?2,[r? =? KҰ>) Rh>znWX%檇 1 VQݶ| ѻn^zwr< Ve߯an?l?H{$vu?:d9?Y2 2?uIi7Z?TB_C5?9ex1?'3 ˺>;疷]QukNTLڪk#Y 4-~3}QwT ?Q?H|ƿ]f=*~>TUid=Exjh?[a^;|ؽDuhM4@J<+]cAyǏ9?H7j~E?]ڪ|?c2 ?Ky{sT?_@SC3?D:!$?1?"UV"?K.>a >}]vSZ[-sЁ܊;N]¬6T=H_/Ǿj| W3Xֹ/+%?SCP>@1?6bG ?jIm? o?G4?t·\8S?p.E6'?_ Y?Y7; J?3^SEN?B ?(IT? O>L>KfR??Fk\a\F?DXfȐ)?4Of=ϴ?35a^Q2?#%h!??4?ϰ ?"?h܌]*?K+ ?ϫR&h?~?lIhSE?ݶH9?P֛d?ז?g(?xwZi%wLet"١sj!D-Rt ;`tu%}k͇r cA Zt6nzQjF; .sepr[n{m <;fVHT[ -?S?!?0J ?a;i?.eW?mSvHZ߿p`QjSoie`_9fЃX$lP08CsEq/PY;W{^Gh&1fGY4c!Rh b#-_Ŀ[oXEO?a?д",s?>?ҝ3?'ONBr?DE1?0br ?\?sxKQ(a•fm˿qGyqܚJbfb)m8y _MLr ݿTA-K۝ kBFzp/ m@&ֿh?Zg[[XmaIG˿?}]?S$k?x?u ?T6?t-?"?j.?eG =>SXEYvAi׿c}b;lXxR&߿`˟QdG]֖?.n46H_ÿaW6` u][ɘAtZe BȿSX ?2?3??L?X`W?Ե?u1L(?L<X?Ҫ5&9pp ޻@X1I%ֿH\qU?%وEw9S6$Կ.4g$:\Wk:9)ҿG7exEW_A7B5Ab9l(?}?κ#?Kd6|1[^C/q ȨoF~;D`N?2PO?0\?6%?A3?A =?7tב'??=>B?0D3?&3J?r?mC?@H??Z?:s #-?9J!SJ0?3M?!?uI&?Ͽ ޵$FÉ8iֿw$OVP?;&?@?0)?I ?Iﻚ`?A?GL?95 WE?0.>!?&v<׺?!ni?I!E?GJ|1?C @?B)X?< @9c r??IW{k?^Ͽxsa"v )o࿱aUm[d1S57?Q*%"?U ?`Ƥ?ܥxT?`гȮ.F?V ?^z?P^?F m`I?=,Ҭ?28J$X?`M1A\?^?Yբ ?XϠL?RhĻ-A?yy??|5Z;) Zfƃ~YT?S"Z?Xz"?bIq?bY˦?,}?Y5?aD&pe?Rtr?H_u5?@rD\?5T@}?bgr+Mx?au~?\-N?[?Tjֆ'V?bz c?!Ix?֊#ك%J>M@V(OYc>~ztNEK?g I&e?lId?udo?v@jl?n(Ǝ?2d?t qs8?erNs?\7L?Sm[?HʻO?uX:??tG;/?pϜ~?pZV~?hM:Qv?aOL?㎀e"?ʟyֈW z,Xd|P|~vDQs3N?`?dk?pQ|u7?p-8?et@?m-bΏ)?X4-?_ ?T2?K<1&?Aup?o1Vުbx?msR_d?hmYp9?g[>-%?a%n]?g%l?b?`G¿YJ 5hLqӮJ?m"qu?ru5?|pC?|K<ސ?s:C,?y(#?k`j7p? ]?bj[A[Jy?X`@?O48?{ Q?yji)0f?uev82?tQGk?oy|Ǵ{?:]?E8N2Y?ǴI㶱VΏnz=lі>ZoTbԉj2?r8su?vr?r~I?Rr?wH?xJ?*?#?pU?fK$p?jK!?]rX?S"l V?I߻?qӴ?zm?x}k3S?r3X,$?=?O%~j?-o"^G Ή@aZ࿲FFW$vc?uv?zu`8?`6`2?"4?{ȏ?0)f?s=>?jyZ!z=?e7H?`%o?a6?"뙰?*׿gAX~oemH;q|9?^nA?c%Ҁ?mp`?m"F?cq:#Xˤ6k)|ij)4?lm㷮l?q*[#?{uw f8?{.X?rKp$X?xz`M?j n5?ad?W1Hg ?Nay?z.~5?x~^?t}rk+(?sR?mE?U8f1!o?꾸+p*gq]y%5_u6 (}#ܱلWLE2N*_I-|EJ&SE3h[ y1Np`9An Y.8"?1hBzZryR Gm`Y?RǪGO#g?&?nd?^:}3?5Xi?,"m?(jst?0Gm?4?lp3`8?vWQk?aљ?VFi?Jr+FA?@l=iҲ?y@p9?x]?p2@BL?o`6(?d-j&LͿ>[`/-^GsLҿr}sR_҅n SSi%DWKYY&UKz+<)G/ Ŀ@$R޼?'}3T> > lrEd DԡN0ѷ20O 1V7̿54?;a?رE?Hl\?b 翸ܓ4TnrenW~ǃOx~ږ+lf[Yz~N ƿ;az;,*7:CO?aC[g>E>OE?>Ҩ?o,F"? 7? >YMN?>b?){͟?gԾ_>OPg>~`Z;0 ?lf? b?ClD)>`.?ɒ?7ƈk?ag!Gձ}d$x-L!iAm~VΧ^dwi`)R C7)"֒~yڞA?Rqd@?Yeq ?̌RQ?.gP??ۗY>G1? M.6?|-KW2S?]Mm? yY?:|#\ ?a?8]kJ?U^-qGRKn)wpܱD8AE)lUrTŭ'+KpϹXjFl,ſ85c\kGN y3J?5? {J֥? k?"ڑV!>;O6>3>jSK 1?POi?\#%M?&j? C%{ؿ.>?%?ST;ο)*\nyk髹h|.?fP>x\`}R=u6/w Ҩƿ '{ˎwp?O?r6_v?-oP!>/>(Z2@ >:xA}>f B??a?u,? ߋ?/72?? oMe)FwC\bfy{}bE8iZhG1f5USe)e]' Pae٬? >T߸ >d/!>z&>=!>>ȽV?8>Y??6>J{8??&KNM߿] -%4w {OWN{Rm>eP†+^k'ӿl&翿Uz  (UR֧>Pv>_=!>i}9>Rmi>^ŀI>"1,sA{>_@d>w>C1g>=ekp>ZwA絿~ ? p?Hs+v"^H /Ǜ`b/$GB蝹e)Gyg&: W K-NR!UM~I)is>qzTy>qnp/>ށ[{9>{>uv)>Yez7>c>W?@>RM(3>53~>vI|??Fw)X/Sm^g,!CJ2AIؿ#_\ a/0r@K\kgIñyÂJm>ćh >N3J> ?k>z[>Ip>+d>m_>h->ÄY6E>Wc^>3;_=oo?l@?-T}N`?Aj?ce?B?_RuZ?DCl?3F\?$ Z?a%>r?XԾSu{8_/W~b9Pzc?s 7mHܺj2Ihd ,zى\n&?# ?txH? v_?NJ{#Q?i;4ć{?Ixg|r?0]PHU? 6m?V8M<>:.>%_nBM;e(2wSㆌ~9W9QKUB ǂ]Ҿ}q慾e/}l$ؾ? ^?j?;ҿM;kK?ʧֻ?jǮ?XN;?e⻩?LZƂ?9ue?+B+? gG&@>Jh寱]5f:dȔA&- l$'izF,EC:6zojnF!U#οNkʒ/n۷S? N?4^mUe?a'd?rE݇?xӊE&?m0#m?SC+?A"?2!?Y>~vu玿 (6o6KϿ &ڿYsYΗI2W첊ܾ\w ‚4_u@@t#ۿ??i?--o??O"?tiv?Q&?pK+?UmBr1?C;B?5Z?s9>.U=yY BfKhl |FW: te]vV ޤ{ ')5waQBH??+")J%(? ?x1Z&&?` ?s";?Yi?ߓ?Gx?9n!5'%?#SN>n@E=z;Qpa V SWJkпeKJuXCA\!3Iy`K ެCvK' -$P3$?f?󼿼*xab?ld?=[2?WݞI?7jUE?6Up? ! C >G7>/:w"R\>v2Gq?2㡾`O3ˣ,FQ)/F01ë ,#,DE;Ӟ<&%.=}s d ɘ?`>><>qݘr %/驾#V*;4??j\/)*N3>H#:2Zt>U"dA$l:5òFnT~f`U$ҕv$)f^\*(? ?jʿ¨!3=&?q?aON?|haƧ?\\6@?B+!?1 .r|?!v?}G0D>޺>r_)#~DǮʰ/ \o־>AKzǣpоx2\LGH %v5p;\c?D]B{wQw5?0V?e Ә {? ?`BϠl?Fw=?4)?%g?9HGL>EL])7S }ٷ}&jv8qѾpe^mpT(|R#m;#y|? :E>NV>&8vm ?XQQ4?7 ?E7ۍ?v?qѱڽ{?ag[L|?\}?6şT< ?BQ{? (?-(>UBdD>??G\ ݌ml?E;xG?64?5(BP_?%2wnm??E$?qs? ? ?r?U?Ved?,p?zMA?GrS[?`{f?hO9sD T6>Sٌ@hȝ9ZVfKk5$_ߒ\_(E S zsw ,=,UT*TWI7GT`}:Q YM#?N?1_?h"&g?~IҦ?2PDJ?&?H_5*?S~#( ƿ'VM)F #dF h~ֿ`x_kvN}==%jbf*3OF} d}![ij D03ҾЋG]%fw9#xF6kqE:?ejG?EE?1!N>M?| qSYpTǠBɿ tbV|j_[f?t>mR#>ԾBɾkDDIq0)C(Ϟ:~;έ$ dt?Up2?H5?-Jn^}Zm1M,?:=GiH/ɫ&?!Rl?E)I?$Y ?'6$?!{?2P?N?h>p2>>>@p[>-- ?wMR??I6>kV]3h?|?LU?4FեZ(/8BXHz jJ 6?3ȟ??7T-?1Ȁ"?9} t{?3;.?1l?`?"F˳N?1"Y>6R>)N>&I?&oW\?$O>B$?ste?g}(k?L? ?o?B(v쿑8qgDm[X:Qvf 3?6̬'?:y>n?< t?:?6y^?3qӀ8]?/&_?$5?,S.^>Թ_F]>e>8;ZC?)%?' Q6?Ϭ\?gn? Y"?C? r)?WXP鵔ƿNyVdV~"p?@Rt6?Cc?DP ?@+-Ԫ?g?;r7?ҕ!?.%@?O>UX>d˪>J"?2mk^ ?0!]?#zG?"g"m[JL?ϥ,?ڜ?|/D?"C߿}U-RƿPQg\Rey 4#jdϿ?A[F?Db%?F^_ ?AG톍x?=w%?%lft? "c?0h_z?ء%+?Nx'>g&>UkS ?3y?2?$>5?#ږi?$i0܊o??gr;e6?Av׿Yѿ\vs Θ\h祉>(*?A(lJ??On?2$7mw?1-nF?"k??e ?ma?w\V rnJ 9+{i?H?L%Nʶr?O ė{j?G.V?D3›?'2[3?6G??al?x>Mer>t?;Tb5̜?9KƷ?,"Rm?LS+S?Jn?=Grf?bCD.??P*x ?Mg%7h_{>〡?9"E? vT?7R'?+v?)?{p^B3C?mM?%I?K5BߔV⎿U7#קl[C{aO})S?F"!,T?J;?M.v?Ft$&N?Cn33w?%s?5R8?ד?0'>g d>4?90B?7[j;?,!:?+ 9i?)NI߿?y,y?CI?փ?P@kیPJM[I}r <0duq?L?QL?R?L6g?aAr.? b}>.^>ࡾO?@Oq+?= ]?1E ?v#&?0T#"?!W~Կx?]?"֚?W/eX\06o[r\bq\h0|?2?Ll?Q1yg?ReMB?LvJu?HZA?+pQ?; 76o?~8? &>?@:\~6?=-3?1,zL!?0>i?j5?!qRӱ?D^¢#cBT1uevx0D=YiIٝ?\y?]Y?^ZZB?VK/?To̰!?7 (*?E ?&Zl? /y?d&g 9>?J|C?HDע?:|Sz?>?-`pgyW-^|>5&>d%59>'`+X3@ 4[(;~aKJ>ゅlÞ)݀?$K׿?Z?΃?Rjv'4ɛ@ꃟĢ*|c3D;Ão ؿ%U?e4~ʽ?a:?z?W?b]'̬?qC?_U i?YdT?YKyB?<P ?JsG?*x ?l ?HAsq>_3V?NiFpi*?P;zqlR?@7f?@ң?/1* wμ:?ݿRw?sC]4IbDwv-)nѢ{5r?]g?5?w/'?xu=p?Y 6L?h',.`?G_ ?6&[hv]4?"p?\%-?k|M++?n?\)eQ?_)P?Jݼ38?Zt' 1?Kr~:v>\5z̿W96 seu?I*?h3BT?bN:l?cһa?DZƀr?SmL?2AK?!M? M^k>V &)?U4.٭?X_Q?FBӢ_?H{ӯ?5ۯ?hkLG?GϿ}D /b&Bsbeo@uXΔ @0?&E?B;C7@7?<_@U?<{A?>K?-i&u? K>XZY>RѢ>w!?0Sh4?1P$?!b܆?"} ?S2ǃ9?*,ՂS҉??90?wbp?5L࿎?s2bLA?7-}h$ 'ג%d(HԿ&H)xMO5A avh?v1??s4?76?boLV? *?Y`&q1<,G?r\$ޱB -kp"U'~U#77"6/ĿF)T%%,t-خǜb)-߹pDH+Kjm6o9j ݿ;؆O(Veo?W7jIe!?r?Q)P? m??бD?+$š?ele-J0αU]gVb(ZQ{bH`!%˿CWMgR[C2<"!ڹ _ӾVUjP4޿WV9BF'㴓G}a44{q-?GJi??")?s)O?n9r ?W|?jm뫿O 3nՊffwcgA^(SH˨x0ۿWo!6uݖ߿%pƗ!g%WQ!Z{ƿ]<WK`οM[|O\:H + ?ű?]X?ѳS?'6&w?Џ?!?x#Nt^|lF<ۿz cٿu[_zuHunV|Psmӿe+ؿDr |Dտ3ԎQ΀ ө6Z{ڿhVʐjTYӻ[M+5݈Hh6?ϳ۪?P[% _4???QX+`?ml?G?riVK#t(y^ n&ٿo*_VPO[(`$Za9]=>y -,ſЖGjéaaHտc!x2RsſT$gAm<пO?撽4nxѲMxK??_d?\ ?eS+e6?i:DM?)"HC?7qK?Ekd?u)l_λ?`Ui?JE0[?W=SS?C? ɹo?v0N`:?K;5??ҵx}?\?_4ꁃ?`H~/?"vfu.[zkM|||Χiο_-omfտLϿ;CG|U@S('Loo_c9QpÉԠr0@Zxa^K9b2UP?"?KPH&]ʿ=7("bD֚乿qrzzq~Q &/@6Omտ+!՜hL74ſsw˨u- f"1d-J+eQ DǬG?s}Kd?o?m'R*?i?|-c'}?{Y?w˛hf\FVy t)tb@SUBÓd b4C,e x2*@m 8S9 d+ӿg;ii`DXAZ} [֓ tG_GFC'?6NyC8L?vLzF?;O?O֡:?v1?; v?;qQI?إk?U?[HqS?`Fhq? "=!=f$;Qt~9~>@d>$?M(?W?Uډ??ė? ?]kZ1?ˣ$հ?T n@?z!W_t?Mn`?Hq.?H0$yxMW5vAGCO8B'g$48]W&J0Ǵdp`Y6̾〻k#}?*uPD(k+niqiD, W}Yk43p U:i\?j0?],?kAR|?L!&R?E1?Bpx~?w?9(E)(\1:f\; 8Կ2lmI/رZG+ !QgԿĶ7\<~پZȎg . Y3$F\"$U^hx}l;޿}}?G?]?8@gg?!dȵ]?Z ?! U>1?4W?HS(cx&v\`tAa/X<3#ӟhrľ•aav-#HCgf۾.dK(;ժ3a vӱS~K1Rg??]]C?I/#?.z6\F 3A6|ۿ5D}?2"?;n? *퉶?*wM{?"70?k=TE?Тyy?f7U>f_>FD>'3Ek>;Ɣ|?8y- ?r%?ފӔ)?ݹi>+ w[??]PC?C-[9P|Ȋ9G8CDεEL?*{De?1$d s>抶>W'%?&oc?$I2m\?Պq4?nUb?,Ux`??]؏5?XCHRGŒJo׮ƿFor2ztl?-Eє?4%X|A?@5hWN? Fm>?6L+?2?3'"?>?$|-?SD>t>N^A>:J5zP?(]wN?&b?X?"x? dvf??]0?QWJGZ~GhڿSo|䜿P-2y?5tg ?=@ ?GM: ?@9 jr?Ǔ\\F?;tՏ#?v?-B[ro? ;Sq>h)˔>aH>h4B?2/q{?0?" :?!3e?wVg?f?]싨? % !u\ZTƒ8$Q} N%|u?7 WЂQ??:a?I0y?ASD"o?=x5?bܼP?y+Y?/d;?8At]> ͭ>۫C=> 9?3=X~&?1 ]x-s?#?"aiR?տ?V}/??RMh Nbg@rA^ˆ09d?B3?J8a?UN1j??MAVy ?I M?*c ?`l1?:qX?y лq? <$g>5>!?@-5?=rg;?0ƥ?/H? tڑ+f?h?[莃?ԁic#^\0X$&>Z??٪?EJ2ġ?QiB*?GEƠȆ?D`r?%~ɼC?6v?!N?~~?n>A(>,?:0A?8d* ?+t$ ?)k2=?DFG g?]q? r?sC?]nqY/fοi{Deוց3]&?LI7\'?S)Jd?^@~W?UBmni?RE '?3N?C\$+?#'DVA?"{!g??2>t?Gdu-?EĊN?8^Ÿ"P?7Y?(3aRG??]nq[t_ Xm@տiT~w7/"=?Pfb?V8w`I?ax ?XӶu?U0sP?6cvx?FZ(?&6YХ?`R?RF?>򋪸\?K_U%?Is ?׺??N?LX.t??ް9?>#!?/&_˿?X?QŠDj?٤b!οZ봫E>Wj_΍;%!Ծ?=?D;E?PQ^#?Fs y>㐪9Z?8@~?3"?6ܳ:%?)k*?(N刪Ϭ?9Do??\#?)ZbP.DZɀKtW[mj%&ȝ/w?= h[s?D7?PN'Q?FoTrW?CHȪ*S?$`݊=6?4ɷ ?7 o{p?$-Ir> o!>;?8L[+?6sO? O?) L?(JfW?bL?HR?m?y:gj-DcaP=]8^Zׁ+B<>.??=eC?=0W*?0ye2k]0?~D?.Aw? JMk߳??ѝ:?>hk'˿g|!ſa͗:y]2,]Jk?Bjڌ?I {#|?Tg9?Ln?HG˽I?)K?: ^A?22?G/>\>U??W(?<)9?0Kk)?.uV෢?}78f? rY?=+?ǐ`ͿDzTKſn[pf꒡eֿE0$[E0ÿ5 0&NUPPkH?j;_;?F*9?X&X?4K$IaI?"eL?W(>yIw:?]m:?[۾n?K0?JʷMK?9{ [r kgݿsk.eXbE0%W㊿M1j@3F0w^4Ͽ(ޥȿH`v8f>p>ّז>)$>hG5wPXkwߩq>nT7%ޕQ ?0?}?R^x? Z|y #N/пa&ǿ]ɵ1?2U.?pJA?jR`?jѾ?NF?\  ?<@FiO?+/B?<پ4Nj?) 1?^T?amF Q?PwY'?R+??ڒsC?&d{*/m?"ЂAtv2oZ z3`x=8Vw?cc?H0g?D;G?D̼QL?( B?6&H6?\/?z1:>>T`jH>UM8?9-=3?;Kp ?,_b?-6Xt?]bؿ ?&|fĪÞ??BsC}ݿO/nTa3}s ̿Smَ_?*pwāN?f|@GJ?aਖ਼y?bjc+?DS?Sa,J?3es=^?" 2?3%4>C񢁺?UhT[?X6)?G1 ?I R1?6AP^W?&{~L?]E y~d EWy+gČfg¿huJ@7G?]LI?R2?M&?M8.Q?10??I? 8"? c>׺>W+H?A&?Cty|A*?3 4VNN?4d@x4?"cZC ƿ??&t\U6h?|mߜ$2?07=?*%z?+584c?Oqk?,mM>s>84\o>HWx>W#? &Ƶ r?!o?eD@v`??*l?&`C?~?JִIL?DŬ?An?(ʿ?pfQ+ƿ c}LDPr\qZ+T U],R.B38׾9^L{浖O(_/-7@0@B|1y%Վ $Ao?&иN/?,?ISo?|%"p?0\Ӫ?j^Fh?B,jX[.ѿT AP0D)<οP>М6tK2cqA5tԫ!¯'6–S}ҾHqbCv¢EQ#H5#ߎ1ٿ6;:G$iyuĿz)?jӿ5yu?\?Ubw?fp6?\V;?x{=o"?Qtʛ&-+Ivbwwz^+\H^8vhAo﷿jwPn8̩`,00 M 6 @|j^RET/aC!E&B!3Q!I0",?'˱Lb?{?Q? @$/?haT?q!<.?I8%ܼ[ qZ}V'5ֱhV\B9+tլH NňӸ8(p%#wwd*ž̸ݪJߴ6M_P1lg=HG>R,A{1???ֵ3?pn-1?G/DZ?c<9?n͔\?nyK4k?^lt?NlҿaDM+&.l6'QWzU>"l~8?턿53C?2} Ϡ 2} ٴt.lp-(?L?2w?u-h?0?P?z` ?sjq 3(\? 4A l ? 4I ?8s?$;z?.`n㿖Elfp 3}?Y N?|?(?Y ?E{&r?&ֈ]-??G"볡? ͐?Ax7?U_Te?Z3JU)C9/MIj f; jpfQJ8MXMz:"9 mR=(5iHbfcsԘ[$]ooMLٜ?O>'T˟L-ܿZ?h;=w65*@Jmx^sxAnjs]!$`WPP_Q$ﺿ?T`'_?&` u!"?t?Uh۷?p>?At?nq@?FKJ P4#{vW-:;3{SaxkSr)dK6b1DVx)%@HE^8WJnuN'yG+u޿op.IN:9+`I,z:%ʏN(vDNǿ0?&ſʶf??+iԁP?QگM?-O?r;AɡH?J/k$8w^j\7CǿVQoϲiW|%:˹"Hգtӿ)Ld %g*Q~Ͽ)735wlUKNy{XkL*Eֿ=ZRY%E?A,F5V9(??94aBk?һ?m:L?:r!? z?t xrd?N*mN*Iٿ^|ĿY!DZ6=|{D$KͰ o,^I>"Uճz_T5ӘNMP쩂j@S4yAx<0u-?/AJr5??06Y?ၴ]?VD?w:! ?P &+)ݻÿaYo\}ڿbP]Q:1ӿ@XhO*]Q/ϻO3̿m-ƿ oIRpQOum6S=FĎB՚D ho2Jr.v?$eeYa'?9)d?| m9?F!?zp[,C?VS7_?=ˀhH!ieÀg^ހ7`uR`yA5=7O5'u.ޘͿ!|п"3aѾXę?K~d?pw,?]a}?x?Ry?P[?v7E?p^Zg>{ B? 7i>`T8=fL\<(Pu<@+M?2n ?%-MV͟>/඄u>->1:#wp?6Eܚ?zz?߆`=3?Tu?ֿkm?@?$.;?/L?v+0?Ɨ#ߤ?ʔT?^o?7#=7?Yhw} 5^o p =p~U$rt\^ɡοvB_}xiqDɊg7lqDi\_GJ;(]zx5fU?ml?c `??@Bq?8nU?쏧ū%?Ӟ_{?K?CVWk=b.v6 mVͿY{q#8t(Vn|ϿmFԔ{dG% [s.l-ud sVI?CO?u?I7ZaIq>s(/Bg*g`3_B?!,30+?7v p ? ?NɥG)"?O$Xf?I?P p͕T?Ck.9C?;{Ux$?3?)?P?OȰ?LN(d?K Uv%?E_(? >?K֫5?KJ ^ P92:7ۿ9 J7:E?B}&?X>ׇD?pY'{?ty?qr?m3!n?r !?e🰰?^װsA?Uy 0yd?M3y?sNȟ,?q?oeok ?npHk?hAxRN? v&a(W/&пB|?bDm?xQ`c? ?Ntd?0hx@?ǝƓ?>?]ح?5~?};?tӛ?l6s?] l?MO(^Y?s)u?x"?˪#hCo???pYf]-,Ӹy߿Ncut ?f]3W{E?~[K)?:?S;`Տ?f}?OP>`? ?r? |Y=WZ敿BQ>Կl?o+?eb?f} ?IJl?´?_?t?oL?5N?>H?wx?7wIu?49H?$B"L?,?mU?0s-2? y?:Q8?|6= ޿;6Ͻ+փs/`yLUa)3?Q*ݺ?g`UJ_}? ?uP(?{9,?8Y?t!A%?l^?d, ?[Czx?鮮? 9)#?\?}yD_P?|rH?v7`^?b}?ƴ?뢿O)xdUħTCv]t=SU[?Qy@?gH?6?˚?{^;8'?m,?tN2Wu?mVP9?d:'?[gGf?.# ?.^?/@?}g?|W.i?w"*ؿ?cI]?\uJz?#xN￿eM2ڮ{f<J9J[-`$?Y; ?q8q?(O?m?&?JZ?~_Gk?udȟs?ms۩0?d(Nm?Z?c??a?x$:S*?+V To?8j?(?4m?߿ڢ*>ӭA@ʿڐ]Iׅ|㿘utP?Y`A@?qn%T?cb?\?3hx?k叫?~$DxPw?u={g~?mp?d ?[-j?Y?X\!?.V??Kl?2}&W?|G;OhΌEtȬ (g]?aR$y?wSƊv?od`?i䊊h?qX?m0?&U?|g:v?sͭ?j_+" ?{8gɽd?zC?rA?r I-w>twJVI&п5"?5.dķD̕k(TV?F?ڃ?z?An-ֿl 8CypM=5fvR 9NeBWVYMQNSZ? L ? Lէ|Ŀ2V_0L*x>38b>37㪧>B.̿42\I}3"y'ca 汿 ٖOD?38+ ?4݀?@NwB'Dֿ>ut=6IJ^sl7q^qDٿBda|@*<d.0Ƽ?7c\? e>X.>on,3%RX˥$-*c?x1Qq?y??\'꿳\x|d jO#gO^|Ha)&I,ef"N TUm׏F'HUܿ {X ?!^Y?=W?&nr?ѷ3!? qҎx?y".3z?eZ?Z7?,+|?"%Pye?5h?%??(&߿/]K6y_uXXKQt)1q{d[.X Iyeſ<%}(j)σ KQ.>‡-H?O=m_׿@L 2|H0z6XZ? +V뮤?}*?Ifz?æ>>$js>},9?w?ǔNX? P G?^f? ?1ÿa}а5_-iɿg V?_.~>ϕ>d1E}>師 :>t<?ZO?N?k(+<> xo??ٿҎ,ȃ`mR޿yP2.Ym6NA=Hܻ0!m!9Y)2zB|ꟾ>iM>Hl>%8>{#OvA> bS=>UA> >k;s3>{B>aE >`?o?nӿ$OڿynXLbD-eٿF%G}.Kf֪GYſkDӔBJll]>'Re>X>>2>ݍc>>F,5>ɰ>Є'9> @h>C+ >hle> $W?C?? o ҉}`1M5\[LL9/( LzjeM٩CShH0S>Ъ)>Ŝ\2>͐9>]9V>ثA>]7>e&n>ņEj8>ƶ8_>д% >{q:]X??] B4C?T$?d>1f3? J ^?`=.n?Ej ?4z??&0a+?2t>  Bw&/8H'#7p|;;Jg`?cwHUǃ!JADTҿst58?^?O翾|?}0z?NŪ?hyx?H2R!?0; ?Vw\?|('>T}>E>¾~>x5u?&GSӌy-L0j*8!5nx`NgQ}CU8 F/!Zw7%+T??d %xS?;f?lr!f`?.X<7?fn [?New?3#[Je6Dϫ:sb˓ G bȾs낆\SU<ٌ.J=yas"??]0%^r? D?spc?Cc^?n!?TWf?C]ۇA?5anM?93UXd>씜v4 -V7l "̿i-˿waObzd 6ž,gHk@ܿ %*ܖ& d"jѭo Zrο?m?Zܬ8܌,? .qm?vES`?C5=~?q%?W8a ?FHQk?8" ?7: ?@Bq$_lf2 B Z/מ x j=-~Jn]w4 A&v!EK.I0)M r}|??Y?M Α?yfS?֕Y-?tq]c?[A9?I?<_?KH?ϢB%Q_>wq>ù4ӏ&εK^7ʨD@VԒΤB9h1*ЏF?#8bԾa n\??Җ⣿l3?} ?QP1?m27̮?Lė?3CI?!u? >DŲE)>%O1Sݾp;a+GBCg7YuL#(h3/eP.!nU)8m&#?8??3P!#?3u?[eڐc?uR P?U\+?=`A|?+'Ӎ@7?)>ƕ8i> .p#bd8yԾM_{)Y/>ߺ zϾ<# @Ic/Ծ&r㕟??Tw=(?L3?b?לW?} }~?]Pp?CU9?2R>?#WB?D+>X/{UO6`/5OR´V$󉠻erT೾^myn)'Q⿕9"C`:Z-(d?fl<$e A?^?f0'g ? s?a|?Gg~?53D?(|yO]? RO>*ۼտjϴ( Ei`GɾFj z<z#~p]ҾyzKڐA,oϿUa:~N^7=%?~R [>}kŢ>%=?Gܬw< ?&?)٫m?KS ?ITo9?:Yo?9Yw3_?)c ??K"˕'?m*? B?:*}?|fb$bytf\ Z@R~xIWš[A@Ggjef rs~t.d}clr^|V0Z]q?V?л[‹?c?Hc.Gj?SQ?n(h??w_L.?EP? X{?oEn?l뿃?pAvh[C@fQ,[`ӡL`OÔZ@HԿ`L%ݮT_9K4C `:ǿ97dȆaKl`3'_ 0&1\X,<10!Sr^%ԪNȫAM)q7I;.nH0HBt}?\i8?!Y)?q'i(c:ݿ~1Dο^DKtM94#m? |?, ?( W=?,.WC?,.6?%Ϧx?+9m;U? %5?~Z^6?hf?ܾ?-T3?+"?(@[*5?'`?"o_}g%* ?M6a?݂0?;/b:lz˼b#o0J8{5xK|?6XdS֔?=;Br?0mK?'g? hs?~diP?>فxR?=K0!7|]?9ھ?85Ԕ8?2Ď/?| ?PK?#aܗyŹDP'PB…f(mgP?;J p?G>0?ZTD?ت_?[;[4`?Ta3r.?Z5S)?NU?D =?<6?3Mt?[$ 5?Z4V?VRxW?U%?b.?P/k?s&?'|?sۿ`"H/\OB8ȿػm5j}/??),?KD4z?^7 ??_N?ZbN8?We؇D?^u?QI';P'?H Z?@q;?5_T4?m3= ^?Ѷja?sSP?f\y 9?^v?T,sז?KZAX?t}ƍp?sž:a_?o[X ?o‡S?h*I=p·$e ?*?)?#k?'xTƨZG.B.e2ЂwdW?K;?Xov3?jӖ?kQy?dV&?jcc?7%?^:5]z?U;Gg{?M F"F?Cb/6?k㊦܌?jyp?f=?e*E;?aZ>?L?{Y?N܎y \ dj Ee,qЦ?YuO4?fI.|s?xap@B?xӵtN?rM3l[?x2$Q?kQQc?1[ч?cVYf+?Zs ?QPi,?yYe8P?x=?t,fz?s?oѷmڿo?ݝ?!?ogj6]̹Ҡ8D^+!NܿDo?_S?k4*ZIe?} /s?~%י?vw#?}8?p ?gQZ?gR?`s?UpCr ?~DV?}@'S?y">?x6!T?r- t&?Do?{=*?t&OR2.[MS('3cX;]v4?bR 0?pT??K}?{al`?}hᥕ?tCay.?l8*?cM'RՈ?-|gd?YB[?r*z8?|P ?~'i{?|a?v4-?yP??&ĝ'´ KYO,] 7»E?ef9?r^?t*8?r ?Kg?. ?weJ/*ç?pJJ/?fIUq?]/j?flv?H$d?'}h6"?mz?}7?z6 /lۿ.?.@]?Aj7D?,z:%1ہjLx1jؿǦҿuI0rD?I'?Vfz?h J?h(O.!v?b]x/?g椏?[x?S?J(?Au17o?i[m(?=Aǘ?g#jUo?hln?b`?gQin?[ZKj?S7/#m?JH~?A#d8?i4 $;?gW0fk?0mR{?dw``?c7a?^ңӿZ?($? ?jzѸ"$֍Gst.~2k?R>:?_P|?q+y\?qJ$?j(?qB?U?c*~P?[W?R2gO?IYZl/?r9 ?qRP?m#? ?lӘmQ?f?"ҿo?*?~{?p,cnW(ؿZ {_~b?R*Q?_zl?qqe5?qsB?ji?q-)+-C?c|f?[ ?Rtg?I;sQ?r!D!?q;_t?ml2]?lpKQ@?T 1-?f&{u)??~\WZB>Zy{h0/&LqXO?X)9;j?e&rd?w*]$?wd@w?qJ+a?vv6?jau%?b]}Zƻ?Y7Y :?Pģ?x:i?vDA}{?sJp5v?r䍜P?ms# i?> iBCs6?ʾ` S Rʿ9׿8<ѿ.k+տp Hcټ8U~Ir9m]Ҵ7.D]ŞʿsHK? wT=J?ZX1?Ok;?{?Ω.^m?*>?:'C'?:;?h?oVe?x9]@?dVg?Z t ?PDXX~?D dQ?z0?z]G?qσvw?qfЩ a?fzA ~U}p5O꣈ߌ:xXsCp㰰̴kɼ-\+XCs.[PCgXr`ۆMW`>gQO^>"HϡR2GCإ3 +`3Yu%޿d`4/[psŔ_?4?C?x?d#71ÿ ]3#u)`q 8TPq[e?@qeke?@q6cM?3T?OG?2O˴?$)Ҟ?״?7ٿ;?3k:?C:3?'t?7r]&?P?{88!/xA$E)rpl%i,G#dOl Կ[9RbV?t}8k#a׿H6zSw,4Ͽ q-NaeVLQbXʇyR?@щ@Gpݑ?4˺r4d?Y?:?n("74mؿBRܿ59(;CitVՆKUhabCW,Ia1y,XW'K|?# 2{?]G?lbx>?8)W|?4ӿd?Ef$? { ? @;?`?#ڛ\?ʜϿ??!hA?o"9T{ۿ|FkFCm~viadk_5*LϿMޟum@'!Y gK??Gk?}6L?M?H- >?f>Av? Hc?~= w?j?mu/M?j ?WۿMK/z>?|>LJuV? tނ? 4g?Hc?SqSv??1EΙ ԎԿk1!! af.k˿N@-/~?9c>B*|=>؄>/>z^70>6E?\?I}i}?v2?_A?ύ?`.P6ڿ1ddMf׿bxJ_W{DZ]CŬD6,2Ոf%c1g>c }_}>Op>q T>y&>2 Y>%i> f>:bSh>Ճ>Zj ??>JP¿??L2+S}o WQ'=%ihI瀗CJ xL2i!!kMK}Rn'm*Jy,kIeP>L9>K"Q>>}i>5;>ׄr>h">ϯ!2P>斅3>t>ج>Aؿ?c?Nݿg;>m>IJTv.TS6< 0Zx .1gQa}zձZcLoZm>}'×r>͵-x>@>x u>!_>HI8t>e/PD}>ź>縅>؜,G9>Ԫ,%?2?gC4*B2??eA x%?K7/z?`:7o?Ger?5pfA?( R? *gH>6J t0xT7: _;|$>j`/n7~AK)VwfS,̾UK ;ł1tY䮿|?j?,C,$?{Cv?MOFD?gL!P?G?.̊?0^ ?ާ? >1> p_>8e IĿu0ÞjF2S\hkJ;I( >aP-09%v~Rꌋ:fOο ??7kNN9k>?osaK?nqUq?i}?gҼX?P~-?>!?1V&?ZEVe:>n y_r4 jӿ=*pXL tsGZj l?Ն8IM Dv ̿@?~ ?8FrZ?1yq,?t=e?BGOb?pl?VGs0.?E4v)l?7E,q?%pZe?}tC7 FÿXW{t"f{v넾Sɿ J(6 uyH U;ܒCXX?{?8ԧɅx;?0V?wC`L? 6ƒ?r+?#i?Z9 .?HJ}?;KC ?+S"? Y2!ܿ R\{׿Y] CX498Կo>c*IžH$nG4е`sX~lm"4pEXnI$k?q'?8"j?3=X?|>?en6?u/?^]?L`*U?@<(?!h4??(S?пo~+ƿ y)mc#((}1v4Cm^blb ׾j[H~AG7 }=J,0t?ߐ}?(?&)' ?c{??5ަR(?P<Þ?1s5?#?Ɉ] >B DV>9N,>ĴC2ҽdhQ >ya}g"v߾@Qj5'1Ծ׌Thw1?г5Ws7Y濤 qJd+⚿n\? ?3IϠQ8?sʓ?\Gԋ?u%8?V7+(?>#?,%N? @bL?Oϥ>!oc־L/̠|FE[/^&=^(d$XAfվ1îd p=ȿAmr8þĥshd D??3鿽NL?Ӈ?b\?}?^=Y `?Ds0@?3?%/60? p=>znI<3[HԄվ&ھ}UUFfCsQv=?R "Df}_?ɤP$F̾v`?7싌H!?%A=?g\SQ?`W#7?b]1t?I(k?7hA ?+"$?C* >d"v]7֧3qv*tY&jop Bj@sت01hӯ_nZZ?ݣ?8>c稫>}x?6D҆i?#kC?7B<{/?zRoYx?utQo?e0)?bϲw?=|{?K&?* ¡N?h6zN? %r'6#>6?PZ `F?Nތ_*K?@ 3N??Aa?0- ɿy??P:]"??U?ѻ/?x?V=\?l` QeD?c5~J+?`&[?l?7@ev¿FT“DFjAHZ#o7'QV 3+ԼyR ) e$0&X8 ¾-mc0"$xXɄ^)ⳝ&xy5epʢH[ uNt;? ??sM?p?TƉ?Fm/:u??Spcfv? o-zǿ._¿-C.(2ah 58e %{CV!5|S317wޚwrg!-?E/T?k?!J"?d !?W6h?d%v?tqf?0`TIAt亿?ʎa:5&1._˿-ݚT<z %E6,. ,( JaI%.g".:-!N+>!he+Xrܿ}2}i-??t?uRmn?3qZ?& L1?3(^?*?,Hѫ |˿Ͼ;e$f3i/׋V4UZ`nhEnj~nCO6\|+ Mj&!LxCPQvbIɁ ??N?lT "Y%ޞ붿K %CXIfז$iAl?1A?'?0`+ ?,p>~?# kn) ? N=1 ?S+G6?>1 ,>4C|n>O4`>;ܢWb?],?!?BNq?l>?A?? )n?lNωCif,-ȿ\*<ht.4߿4ae?C;oCD?B EV?C@H?>;?4@Sn ?1Hݷ_?Uz >>ܩai>XMJ*l> {>I ?(h1@&?&U7l?€P?3I%Cڅ?o?k?0)s=?XP]taF祿fKԿs{3rS@?P\?N t?M,)?HT?@K#6?E.q\?;ϥ?L ?,ю? [ >>>ǙeVN?1/?0a4#?!-N? 0fn?6]0h??Y?@ZmJuUh+R$us.A9ץ ?Po4?O!eR??Ify)$?Ad=?=s?P9[?Eoz|?.㍇vK? bV,>->螱nE>֊ h!?2?15?">^_?![_L?_kY ?qx?ۢUSؿgHd+T*`t3v .f2G_s?`DqV?]*4{>?Y#NOe?Q?K[At?)@L2? i?=/n?{ӎe? b>JQuz>B+R?B?@ Tg?3Bs?0 ?!?o?]rWJX }'~/p 8}[xIzk?VGN?U\S?Q R?Gt]JA n>~:N?9 6~?78?*%?(=5?6dX??ٿs9:+9y!^d2p q>p 5?Ctz?A嵤?3j~p$?2P?#ٔbk??ٿ[^,ۿgW}P8ʿU ^:/?d {>V:?Fj\J?D7 )?6D@'S?56]'J?&Hd??ٿxQdnc>ڦ!rQYY%A?g:4 ?e߰ ?b>.]?Xpiy2?Tyz1}?4'?E!s ?$IN1{?&?L+`c?>%?Ji9?H.?rC?:q ?9r3?)R??ٿ(G]DB1X瘿)_ӿ\`6?j5I?hO?d?[.?W()S?7WaX?H|}k^?&Y?-x?s7{><};??M_?KH?>_W?_?-!/A??P ?>7 |z܊f>Ǎ)y?8XK`]z>ϻR?8;Br?6.Ϩy?J ?(jwX?' z!n>?o2f??W?8؂?D3YnEKҝoxx|4jmɒ\[ S?U5c?W |S?Sq;P?JH4q?G |v?&72ه?8|46?؛?lt >꨾ >H)?=Z?;v( !?.?]?;/?,r-T?r-}u??^1E㿃Ơf)q+bn;x׻A+btOc?^ 2?\6 ?X]vF}?O^λ?K]$`?( F; ?1y>۠g?@V?>GL0?2>w?0Bמi? %|?_.oR?Ƹ=CAyΫY?? <`-2G9j$`KRfqp˓bzMaٿkgfvy$So FU e$ u#pར{S\iǼHA<.Ų%+)UYԣsŚ8U־jneiOe]?f*rv"Fw?w 5i?zғE>?!t5m?rL6A? @w0?zb?l~m?h8>_?CMQ{?Uϟz ?1mg@ȳ?D? zL">;'?ZPg?YE(zbd?HaY?G#&?6,$PrGq8ɈWH@̿ҿ&^gabQ L@ftDΥ-5QM%gq[N*> >l: L>"L>E п jߣb& 4u0b qV>K]ᦩp6??hy?pd?K?Mƿ8qսDCb?׭m)g  h'$-/) GD%N9̮,3^O'BؿB︘ωߚ-B- U$vϡ;HA xο |﷢/Ca 1V 6?ȿN? 2= /&pH(p|@SƹsrT/pRu>T rs?pd??k 6OM{)EOGpY vˮ).\mHD4Z\/SKw̧ZJl~BĬ̪E{Ur #QL%'qQˑg>Ŀ^/\%4̮I' 1xZ?'pbuXQ0+ܗG|izW ݩ *9isݳ:]́v(ο,a5??Q6u>'o~-x*trZ]{ꮁ5=`ω+1î%2 9vr vXP7wh[}vMtK=L-/1;ӿj?6eISU -)1j^ r?iĺzG6'20$ 7CNڿU:( ySJݿ{/dA>,1.ݫLG񃊿5..?2ͼC|b1#ϔEt(ǿЍF٠;t@ȃ 5+x&7Waſ֣:ԻO`!zqctF'9cӿv wi~+P{ƇP,tDy쩿2iT-_M솅u Mi j'Қ&)%^EF'Ҋ7db;]N*n!)ǿ}XmX]- *ܤ:vspOjV?L[־߇sB߿q+E~EA4 {辿GLn 5 ȴچʿ iZc|}֞1q*Z40|3cȊkq^|-5,}ø?=!zXdM[qT-yScw% Sc,ö\gcڿ7ޟ[a4-& ,?j9l5rx.yq+ܿjͿ_zU޿#ueDǿaEp3?H$=cYX Bڠ@ tZW-bm7{u9%6^[i郿;K#iX_Ԩdc<۞/?r>]J$챵9-WA|[ּ%iʿ[ .B֛ ^yI{QY@I%72Wڍ0J?&/D*zi:ѾOf$cYCcԿa'"!a/VZa QV?t Db& MV ]H+ H}?-οU pQ&W) {d>3^#s_M5P{yxr h5ҿHzƿ YPA qoWi18hlCGq Y޿|t1^l,os펷f> І˹ o3Ho <ſJG n:?",4v5%+ ,,7 t&U# l]hғ[:? :.m;-7Vo a$eT`*Rq!Ax+>oqՉEUȘbbZRP'1Yn;R<;YBSKbh덕las7둒t3_yN<.dV dܠeTޟm4'Xu տ@%p%J(@5&'B,kxwag?CϣVxdd)3l)XDʦ*Qw z۽!qǿ/E O/"sΖTX.}Hj!Sq*޿5Io;ڿ*0vr5'%ϙ_^3PJ9.?4ҿUlDԢ#X18 hYXlT珴`~嬿Z0VS=2&LAw?S웰 [Rٖ9oҿO,H|$[y=Z ҧ0ܟ! 6Hr._tryYH_,˿ #-= nrMqx90քuDet(C7Foϝ;\nQVB~ܿƓ  G^fUvϽC鬰ſjd5jyɊ^ۿ`^ 3=,:`fk$? ,ƿ$۾D> lob(|SBwgLwп. vI?g8Ln4AZ7⿿@p1JpA#Z--΅6_ )]Ă>񕚸ꋍ^Tg[YxZo VZ"zs֔+ (&3 8`Ͽ령ҽIy੿p=&FԿkO-c2568's0T;pW4`?׋%g 7ZC8H B틿A{K/Cd/Jvjoٿ.~rͿ ]R#s$7ֹ3N걿c@ /1Yn"#r瓿 ֿxLF_HCߗD8W2ERmrHv Ѫ~~ॽV@Նk+Ͽ$MYh5 udSݣӰ Ӷ@6䠦TU0* 'lqND"J?G"/4Yf瑱Pe???@?pdcc'_ac{),.0WbW\`fjnprxz|~hltvz !%')+-/13579;=?ACEGIK%)15=AGIK=AKafhjlnrtvxz|~ ,,,,,,,,,,,,,,,,,,,,,,-///////////////////////6KKKKKKKKKKKKKKKKKKKKKKKKLNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNO_______________________bbbbbbbbgggggggggggggggg}}}}}}}}.X .(_T>r>2?Hcվtm>i\/>"=>cD>O>1==k>@> @ I=C>">b= ># >ƶf2?h7>p )$ؼl>ƶf2vɚ>ƶf2>`h>`hEݤ@4g J>ƶf2>N=@tL}!%f8W>">@>>?,3+33467J"e'/Z_PH`GDξ x&PC58M)z`ﾉZ?( 8XyM?rƿkSA?r1:?p!ײ?]$Gr?S˔5 /?6T0R?-"+x>op ?9>.>Sbku>tCZz >PV./?|h?=J>ӱ6>+t5>0ˬAZQ/!Q/!EݤpçTQ</>n= @pݾF/_=>}2>7>W='== 2:"Ծ A%{?&P+PC@j ֽʀ!>rEYaߛ?X#$?vX>r>?up'C?n ?XHJ?OeO?1$}t3?&&WXd}>١Θs->`lw> kI>|2*>XVj9>3Yai >؉*r> 쥈>q+N ˆ>1MHϛ;>vr$=/ >A(o?rIMV>a=z 87 4_ԥ6'?ͥD%>-BA>>=F (2`>L> " Y=<=FqQ+hD)w #ɀp9r ;~S5<+a5z9Q czN:R#?rO?g|?dC*'?hI'?x88?&?k5i?]e8?NU??:V42%?4ڞ ?al?}Џr9)?|; ?pD=_>1S Ѿ>D=S=ｽ$ I= جx?cx,< wESa½N.>ah>`f>r` @.3"` >T&^(o0*ҏa>-Ծ? 7i=B(tՆ֧ ,wĄ?̽!߀MO툽&"4 L҅ӽ!ȡ8a>3KeBs>R$@%y>@EBNcfKئӑ9Ƌ?{Plj-YGKz6zZ|2= c?cf3U䱬y @I-"\LDY?ey8|u?a; ?;W1@?*䴤WhG>SJC|=z+>8ǖ>5f[>, hϳ>r%sB=J9޽?lܟ= ªq)Oýj VQ۞=T ;M!==Z > VN;>O)Hp?;3?9ƺWлWX!EP뻌SZX?xpO 'YN/VBO'r?7?{h3h?3DC?n⠆1GC>F!zm@ >O4@=vҾA2P=@;k7G>4ዼ f`GuSo@=쌽c&Gw9=CpA;=H=p [>t>~ Əp? ٳRvQe ,?p?Wxg!2WX"n~X˚tXtvZ2N^?q҇,|EgiջѾ$.npʟ/?5TƤ?|J?En>qS?λ>FG_yЯGʽfc> P?~z\;9>,Q)=6?A= _햽EQA?a*@3Y-<2wټy ;;Gk?se@&?m7B=sB>]=0)0Vb?+ (4,?T*̧M%A5?0N?X7Hv[ ZZPLg>ʩsba^x_rT#–#f;}\qWt*3??z?^դj%˻*1x ]pT fT>N[X>+!B8`=B S=]Gڿ=R)= 7AgZkp<yg;5wಿ㇥Ŀu*HD߾|@`K?CR4n`: C Ct o?^7U%?T)h /xu^KT=yh@9>E̿^u@;k=Ð=g=;;鎺J}VKsZ?|Wڼ{ v f^?+r,E/M;T,E|?Ovcsg3g&7?P?xU>Fn?!*h/GQpG ;/fv*?B@Kk"?7MI>AX>Hv=Zٓ3! =FSl;>c>-ٹ@;k+Ā!>Ƭ˽`Us=hRR;>?|i$\=*LصHо2=ﾑ>q@CWG =1p\>W n! o=9>Rd>N>-<s>!C<>*@>RvjPD>>^ 0>2`>A7>'D鐾 T =>)(1>4ꌫG|.1.:ZBiZ?> -?^\̳aGy!?wd*W?lPeD?"Yo??q7%h?{"͌?f.~?\Ơ*?PTD?C?.$-?g{k?s)?s1,?hݏfu~Pt 4;=⹀6)z޽?(=[">2_>@Y/=:#ة== 櫾?Jռ=>@@~1s?]\QM3r>Ұ?ϋ?E?'v=e?k/X?.E?O?*?͒V#a8Us-5Ant3?b&N'?$2?y?$JDXGB]DӖ'W) mUGUGMR,O>j ýM_t2- p >>(: >þ7`V-7>".ľ&8> 9'>$A_>-)< ?> @'> Z7+ M9g)/>@?R@J?i?U?g?ֈm?ж(?Q?w՞A%e]A4MIZm'^49 MZC=2 xZ7HRprj~ zqs!VR$U=f>8?_>W2:$3@rf#7WW>ky?>ŀ>!01>)N,bԾ)2>`տݦrp#w5.n6>7%B? d@?Z?Ms?s$ޤR?椅?wB e}?'?w{PW/'p,+[kۘ`ROcB>ԛzTPyRQ"^ o\^x'0tw$GQ@=UD_>)e[[_=@fY۾ =& 79>>q`o%0>0x @v~> )A0ɿ! ?1~$d8>jf>?Q d?t7*?b)^BcĂ?pv-?wY$?Z!K?u΀@;t?x`^yB?o)]a?fǎC?^ҊT?S*?yU ?|MA?sH?uPӍS?mHˆG>P 2&;>o=Z= Oܤ=X =D_hP {xܾ@ʾ@"3`6 f(0g =x@ b?{Qƥ >M?Zrܾ?nC?{6*<ܯ·AG?gD?ybb?R;bp?515?u[$IRD?gE]?b2m?X\?IZ7~J?pɪ 4?v]?gf?qn/[?g>1QԴ?G@N$&>G>>cD>O>@=#0=j8H_> @ IY??LA>= >`L?˝?h7;=ذ=ſҽr~T={|-&۽Eeq<0j:j=a5k=_="tiy(i=/=ʆ E=0YTc,さ=J3F?P#'@g:?h7{ھ?Ot3բ>t>`N=/I==-h창#}uKr &dU *n(a4#c J2UHjʈPd.@HҌʈPd.Eݤ@4.H Mallya/lhr01